      SUBROUTINE LNCNT  (N)                                             LNC00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         LNC00020
      COMMON/LINES/TITLE(10),TIL(3),NLP,LIN                             LNC00030
      LIN=LIN+N                                                         LNC00040
      IF  (LIN.LE.NLP)   GO TO 20                                       LNC00050
      WRITE(6,1010) TITLE,TIL                                           LNC00060
 1010 FORMAT(1H1,10A8,3A8/)                                             LNC00070
      LIN=2+N                                                           LNC00080
      IF  (N.GT.NLP)  LIN=2                                             LNC00090
   20 RETURN                                                            LNC00100
      END                                                               LNC00110
      SUBROUTINE CNTREG(A,NA,B,NB,H,NH,Q,NQ,R,NR,Z,W,LAMBDA,S,F,NF,P,NP CNT00010
     1,T,IOP,IDENT,DUMMY)                                               CNT00020
      IMPLICIT REAL*8 (A-H,O-Z)                                         CNT00030
C                                                                       CNT00040
      DIMENSION A(1),B(1),H(1),Q(1),R(1),Z(1),W(1),LAMBDA(1),S(1),F(1),PCNT00050
     1(1),T(1),DUMMY(1)                                                 CNT00060
      DIMENSION NA(2),NB(2),NH(2),NQ(2),NR(2),NF(2),NP(2),IOP(3),NDUM1(2CNT00070
     1),NDUM2(2)                                                        CNT00080
      LOGICAL IDENT                                                     CNT00090
      REAL*8 LAMBDA                                                     CNT00100
      COMMON/CONV/SUMCV,RICTCV,SERCV,MAXSUM                             CNT00110
C                                                                       CNT00120
      IF( IOP(1). EQ. 0 ) GO TO 65                                      CNT00130
      CALL LNCNT(5)                                                     CNT00140
      IF( IOP(3) .EQ. 0 ) PRINT 25                                      CNT00150
   25 FORMAT(//' PROGRAM TO SOLVE THE TIME-INVARIANT FINITE-DURATION CONCNT00160
     1TINUOUS OPTIMAL'/' REGULATOR PROBLEM WITH NOISE-FREE MEASUREMENTS'CNT00170
     2)                                                                 CNT00180
      IF( IOP(3) .NE. 0 ) PRINT 30                                      CNT00190
   30 FORMAT(//' PROGRAM TO SOLVE THE TIME-INVARIANT INFINITE-DURATION CCNT00200
     1ONTINUOUS OPTIMAL'/' REGULATOR PROBLEM  WITH NOISE-FREE MEASUREMENCNT00210
     2TS')                                                              CNT00220
      CALL PRNT(A,NA,4H A  ,1)                                          CNT00230
      CALL PRNT(B,NB,4H B  ,1)                                          CNT00240
      CALL PRNT(Q,NQ,4H Q  ,1)                                          CNT00250
      IF( .NOT. IDENT ) GO TO 45                                        CNT00260
      CALL LNCNT(3)                                                     CNT00270
      PRINT 35                                                          CNT00280
   35 FORMAT(/' H IS AN IDENTITY MATRIX'/)                              CNT00290
      GO TO 55                                                          CNT00300
C                                                                       CNT00310
   45 CONTINUE                                                          CNT00320
      CALL PRNT(H,NH,4H H  ,1)                                          lNT00330
      CALL MULT(Q,NQ,H,NH,DUMMY,NH)                                     CNT00340
      N1= NH(1)*NH(2)+1                                                 CNT00350
      CALL TRANP(H,NH,DUMMY(N1),NDUM1)                                  CNT00360
      CALL MULT(DUMMY(N1),NDUM1,DUMMY,NH,Q,NQ)                          CNT00370
      CALL LNCNT(3)                                                     CNT00380
      PRINT 50                                                          CNT00390
   50 FORMAT(//' MATRIX (H TRANSPOSE)QH')                               CNT00400
      CALL PRNT(Q,NQ,0,3)                                               CNT00410
   55 CONTINUE                                                          CNT00420
      CALL PRNT(R,NR,4H R  ,1)                                          CNT00430
C                                                                       CNT00440
      IF( IOP(3) .NE. 0 ) GO TO 65                                      CNT00450
      CALL LNCNT(4)                                                     CNT00460
      PRINT 60                                                          CNT00470
   60 FORMAT(//' WEIGHTING ON TERMINAL VALUE OF STATE VECTOR'/)         CNT00480
      CALL PRNT(P,NP,4H P  ,1)                                          CNT00490
C                                                                       CNT00500
   65 CONTINUE                                                          CNT00510
      CALL EQUATE(R,NR,DUMMY,NR)                                        CNT00520
      N = NA(1)**2                                                      CNT00530
      N1 = NB(1)*NB(2)+1                                                CNT00540
      CALL TRANP(B,NB,DUMMY(N1),NDUM1)                                  CNT00550
      N2 = N1 + N                                                       CNT00560
      L = NR(1)                                                         CNT00570
      IOPT = 0                                                          CNT00580
      IFAC = 0                                                          CNT00590
      CALL SYMPDS(L,L,DUMMY,NB(1),DUMMY(N1),IOPT,IFAC,DET,ISCALE,DUMMY(NCNT00600
     12),IERR)                                                          CNT00610
C                                                                       CNT00620
      IF( IERR .EQ. 0 ) GO TO 100                                       CNT00630
      CALL LNCNT(4)                                                     CNT00640
      PRINT 75                                                          CNT00650
   75 FORMAT(//' IN CNTREG, THE SUBROUTINE  SYMPDS HAS FOUND THE MATRIX CNT00660
     1 R NOT SYMMETRIC POSITIVE DEFINITE'/)                             CNT00670
      RETURN                                                            CNT00680
C                                                                       CNT00690
  100 CONTINUE                                                          CNT00700
      CALL EQUATE(DUMMY(N1),NDUM1,DUMMY,NDUM1)                          CNT00710
      CALL MULT(B,NB,DUMMY(N1),NDUM1,DUMMY(N2),NA)                      CNT00720
      CALL SCALE(DUMMY(N2),NA,DUMMY(N1),NA,-1.0)                        CNT00730
      N3 = N2 + N                                                       CNT00740
      IF( IDENT .OR. (IOP(1) .NE. 0) ) GO TO 200                        CNT00750
      CALL MULT(Q,NQ,H,NH,DUMMY(N2),NH)                                 CNT00760
      CALL TRANP(H,NH,DUMMY(N3),NDUM1)                                  CNT00770
      CALL MULT(DUMMY(N3),NDUM1,DUMMY(N2),NH,Q,NQ)                      CNT00780
C                                                                       CNT00790
  200 CONTINUE                                                          CNT00800
      CALL SCALE(Q,NQ,Q,NQ,-1.0)                                        CNT00810
      CALL JUXTR(A,NA,Q,NQ,Z,NDUM1)                                     CNT00820
      CALL TRANP(A,NA,DUMMY(N2),NA)                                     CNT00830
      CALL SCALE( DUMMY(N2),NA,DUMMY(N2),NA,-1.0)                       CNT00840
      L = 2*N + 1                                                       CNT00850
      CALL JUXTR(DUMMY(N1),NA,DUMMY(N2),NA,Z(L),NDUM1)                  CNT00860
      CALL SCALE(Q,NQ,Q,NQ,-1.0)                                        CNT00870
      NDUM2(1) = 2*NA(1)                                                CNT00880
      NDUM2(2) = NDUM2(1)                                               CNT00890
      IF( IOP(1) .NE. 0 )  CALL PRNT(Z,NDUM2,4H Z  ,1)                  CNT00900
      CALL EQUATE(Z,NDUM2,DUMMY(N1),NDUM2)                              CNT00910
      M = 4*N                                                           CNT00920
      N2 = M + N1                                                       CNT00930
      L = 2*NA(1)                                                       CNT00940
      N3 = N2 + L                                                       CNT00950
      N4 = N3 + L                                                       CNT00960
      ISV = L                                                           CNT00970
      ILV = 0                                                           CNT00980
      CALL EIGEN(L,L,DUMMY(N1),DUMMY(N2),DUMMY(N3),ISV,ILV,W,DUMMY(N4),ICNT00990
     1ERR)                                                              CNT01000
      IF( IERR .EQ. 0 ) GO TO 300                                       CNT01010
      CALL LNCNT(4)                                                     CNT01020
      IF( IERR .GT. 0 ) GO TO 250                                       CNT01030
      PRINT 225,IERR                                                    CNT01040
  225 FORMAT(//' IN CNTREG, EIGEN FAILED TO COMPUTE THE ',I6,' EIGENVEC CNT01050
     1TOR OF Z '/)                                                      CNT01060
      RETURN                                                            CNT01070
  250 CONTINUE                                                          CNT01080
      PRINT 275,IERR                                                    CNT01090
  275 FORMAT(//' IN CNTREG, THE ',I6,' EIGENVALUE OF Z HAS NOT BEEN FO  CNT01100
     1UND AFTER 30 ITERATIONS IN EIGEN'/)                               CNT01110
      RETURN                                                            CNT01120
C                                                                       CNT01130
  300 CONTINUE                                                          CNT01140
      IF( IOP(1) .EQ. 0 ) GO TO 400                                     CNT01150
      CALL LNCNT(3)                                                     CNT01160
      PRINT 325                                                         CNT01170
  325 FORMAT(//' EIGENVALUES OF Z')                                     CNT01180
      NDUM1(1) = L                                                      CNT01190
      NDUM1(2) = 2                                                      CNT01200
      CALL PRNT(DUMMY(N2),NDUM1,0,3)                                    CNT01210
      CALL LNCNT(3)                                                     CNT01220
      PRINT 350                                                         CNT01230
  350 FORMAT(//' CORRESPONDING EIGENVECTORS')                           CNT01240
      CALL PRNT(W,NDUM2,0,3)                                            CNT01250
C                                                                       CNT01260
  400 CONTINUE                                                          CNT01270
      CALL EQUATE(W,NDUM2,DUMMY(N1),NDUM2)                              CNT01280
      J1 = 1                                                            CNT01290
      J2 = 1                                                            CNT01300
      M = 2*N                                                           CNT01310
      NDUM1(1) = L                                                      CNT01320
      NDUM1(2) = 1                                                      CNT01330
      K4 = N4                                                           CNT01340
C                                                                       CNT01350
      I=1                                                               CNT01360
  415 CONTINUE                                                          CNT01370
      IF( I .GT. L )  GO TO 515                                         CNT01380
      K1 = N2+I-1                                                       CNT01390
      K2 = N1+(I-1)*L                                                   CNT01400
      K3 = N3+I-1                                                       CNT01410
      IF(DUMMY(K1) .GT. 0.0 ) GO TO 425                                 CNT01420
      J = (J1-1)*L+M+1                                                  CNT01430
      J1 = J1+1                                                         CNT01440
      IF(DUMMY(K3).NE. 0.0) J1=J1+1                                     CNT01450
      GO TO 450                                                         CNT01460
  425 CONTINUE                                                          CNT01470
      DUMMY(K4)=I                                                       CNT01480
      K4 = K4+1                                                         CNT01490
      J = (J2-1)*L+1                                                    CNT01500
      J2 = J2+1                                                         CNT01510
      IF( DUMMY(K3) .NE. 0.0 )  J2 = J2 + 1                             CNT01520
  450 CONTINUE                                                          CNT01530
      CALL EQUATE(DUMMY(K2),NDUM1,W(J),NDUM1)                           CNT01540
      IF(DUMMY(K3) .EQ. 0.0) GO TO 500                                  CNT01550
      I = I+1                                                           CNT01560
      K2 = K2+L                                                         CNT01570
      J = J+L                                                           CNT01580
      CALL EQUATE(DUMMY(K2),NDUM1,W(J),NDUM1)                           CNT01590
  500 CONTINUE                                                          CNT01600
      I=I+1                                                             CNT01610
      GO TO 415                                                         CNT01620
  515 CONTINUE                                                          CNT01630
C                                                                       CNT01640
      CALL NULL(LAMBDA,NA)                                              CNT01650
      K0 = -1                                                           CNT01660
      J = -NA(1)                                                        CNT01670
      NAX = NA(1)                                                       CNT01680
      I=1                                                               CNT01690
  520 CONTINUE                                                          CNT01700
      IF( I .GT. NAX )  GO TO 530                                       CNT01710
      J = NAX + J + 1                                                   CNT01720
      K0 = K0 + 1                                                       CNT01730
      K1 = N4 + K0                                                      CNT01740
      K2 = DUMMY(K1)                                                    CNT01750
      K = N2+K2-1                                                       CNT01760
      LAMBDA(J) = DUMMY(K)                                              CNT01770
      K3 = N3+K2-1                                                      CNT01780
      IF( DUMMY(K3) .EQ. 0.0 ) GO TO 525                                CNT01790
      K4 = J+1                                                          CNT01800
      LAMBDA(K4) = -DUMMY(K3)                                           CNT01810
      K4 = K4+NAX                                                       CNT01820
      LAMBDA(K4) = DUMMY(K)                                             CNT01830
      K4 = K4-1                                                         CNT01840
      LAMBDA(K4) = DUMMY(K3)                                            CNT01850
      K5 = M + (I-1)*L + 1                                              CNT01860
      K6 = K5 + L                                                       CNT01870
      CALL EQUATE(W(K5),NDUM1,DUMMY(N1),NDUM1)                          CNT01880
      CALL EQUATE(W(K6),NDUM1,W(K5),NDUM1)                              CNT01890
      CALL EQUATE(DUMMY(N1),NDUM1,W(K6),NDUM1)                          CNT01900
      I = I+1                                                           CNT01910
      J = NAX + J +1                                                    CNT01920
  525 CONTINUE                                                          CNT01930
      I=I+1                                                             CNT01940
      GO TO 520                                                         CNT01950
  530 CONTINUE                                                          CNT01960
C                                                                       CNT01970
      IF( IOP(1) .EQ. 0 ) GO TO 700                                     CNT01980
      CALL LNCNT(3)                                                     CNT01990
      PRINT 535                                                         CNT02000
  535 FORMAT(//' REORDERED EIGENVECTORS')                               CNT02010
      CALL PRNT(W,NDUM2,0,3)                                            CNT02020
      CALL LNCNT(4)                                                     CNT02030
      PRINT 545                                                         CNT02040
  545 FORMAT(//' LAMBDA MATRIX OF EIGENVALUES OF Z WITH POSITIVE REAL PACNT02050
     1RTS'/)                                                            CNT02060
      CALL PRNT(LAMBDA,NA,0,3)                                          CNT02070
C                                                                       CNT02080
      CALL MULT(Z,NDUM2,W,NDUM2,DUMMY(N1),NDUM2)                        CNT02090
      L = NDUM2(1)                                                      CNT02100
      M = L**2                                                          CNT02110
      N2 = N1+M                                                         CNT02120
      CALL EQUATE(W,NDUM2,DUMMY(N2),NDUM2)                              CNT02130
      N3 = N2+M                                                         CNT02140
      N4 = N3+L                                                         CNT02150
      IFAC = 0                                                          CNT02160
      CALL GELIM(L,L,DUMMY(N2),L,DUMMY(N1),DUMMY(N3),IFAC,DUMMY(N4),IERRCNT02170
     1)                                                                 CNT02180
      IF( IERR .EQ. 0 ) GO TO 600                                       CNT02190
      CALL LNCNT(4)                                                     CNT02200
      PRINT 550                                                         CNT02210
  550 FORMAT(//' IN CNTREG, GELIM HAS FOUND THE REORDERED MATRIX W TO B CNT02220
     1E SINGULAR '/)                                                    CNT02230
  600 CONTINUE                                                          CNT02240
      CALL PRNT(DUMMY(N1),NDUM2,4HWIZW,1)                               CNT02250
C                                                                       CNT02260
  700 CONTINUE                                                          CNT02270
      NDUM1(1) = 2*NA(1)                                                CNT02280
      NDUM1(2) = NA(1)                                                  CNT02290
      N2 = 2*N + N1                                                     CNT02300
      CALL TRANP(W,NDUM1,DUMMY(N2),NDUM2)                               CNT02310
      NW11 = N1                                                         CNT02320
      NDUM1(1) = NA(1)                                                  CNT02330
      CALL TRANP(DUMMY(N2),NDUM1,DUMMY(NW11),NDUM1)                     CNT02340
      L = N2+N                                                          CNT02350
      NW21 = NW11+N                                                     CNT02360
      CALL TRANP(DUMMY(L),NDUM1,DUMMY(NW21),NDUM1)                      CNT02370
      L = 2*N+1                                                         CNT02380
      NDUM1(1)=2*NA(1)                                                  CNT02390
      N3 = N2 + 2*N                                                     CNT02400
      CALL TRANP(W(L),NDUM1,DUMMY(N3),NDUM2)                            CNT02410
      NDUM1(1) = NA(1)                                                  CNT02420
      NW12 = NW21+N                                                     CNT02430
      CALL TRANP(DUMMY(N3),NDUM1,DUMMY(NW12),NDUM1)                     CNT02440
      L = N3 + N                                                        CNT02450
      NW22 = NW12 + N                                                   CNT02460
      CALL TRANP(DUMMY(L),NDUM1,DUMMY(NW22),NDUM1)                      CNT02470
C                                                                       CNT02480
      IF( IOP(1) .EQ. 0 ) GO TO 800                                     CNT02490
      CALL PRNT(DUMMY(NW11),NA,4HW11 ,1)                                CNT02500
      CALL PRNT(DUMMY(NW21),NA,4HW21 ,1)                                CNT02510
      CALL PRNT(DUMMY(NW12),NA,4HW12 ,1)                                CNT02520
      CALL PRNT(DUMMY(NW22),NA,4HW22 ,1)                                CNT02530
C                                                                       CNT02540
  800 CONTINUE                                                          CNT02550
      IF( IOP(3) .NE. 0 ) GO TO 900                                     CNT02560
      N2 = N1+4*N                                                       CNT02570
      CALL MULT(P,NP,DUMMY(NW12),NA,S,NA)                               CNT02580
      CALL MULT(P,NP,DUMMY(NW11),NA,DUMMY(N2),NA)                       CNT02590
      CALL SUBT(S,NA,DUMMY(NW22),NA,S,NA)                               CNT02600
      CALL SUBT(DUMMY(NW21),NA,DUMMY(N2),NA,DUMMY(N2),NA)               CNT02610
      N3 = N2+N                                                         CNT02620
      L = NA(1)                                                         CNT02630
      IFAC = 0                                                          CNT02640
      N4 = N3+NA(1)                                                     CNT02650
      CALL GELIM(L,L,DUMMY(N2),L,S,DUMMY(N3),IFAC,DUMMY(N4),IERR)       CNT02660
      IF( IERR .EQ. 0 ) GO TO 850                                       CNT02670
      CALL LNCNT(4)                                                     CNT02680
      PRINT 825                                                         CNT02690
  825 FORMAT(//' IN CNTREG, GELIM HAS FOUND THE MATRIX  W21 - P1XW11 TO CNT02700
     1 BE SINGULAR'/)                                                   CNT02710
      RETURN                                                            CNT02720
C                                                                       CNT02730
  850 CONTINUE                                                          CNT02740
      IF( IOP(1) .EQ. 0 ) GO TO 1000                                    CNT02750
      CALL PRNT(S,NA,4H S  ,1)                                          CNT02760
      NDUM1(1) = NR(1)                                                  CNT02770
      NDUM1(2) = NA(1)                                                  CNT02780
      CALL LNCNT(3)                                                     CNT02790
      PRINT 875                                                         CNT02800
  875 FORMAT(//' MATRIX (R INVERSE)X(B TRANSPOSE)')                     CNT02810
      CALL PRNT(DUMMY,NDUM1,0,3)                                        CNT02820
      GO TO 1000                                                        CNT02830
C                                                                       CNT02840
  900 CONTINUE                                                          CNT02850
      N2 = N1+4*N                                                       CNT02860
      CALL TRANP(DUMMY(NW12),NA,DUMMY(N2),NA)                           CNT02870
      CALL TRANP(DUMMY(NW22),NA,P,NP)                                   CNT02880
      N3 = N2+N                                                         CNT02890
      IFAC = 0                                                          CNT02900
      L = NA(1)                                                         CNT02910
      N4 = N3 + NA(1)                                                   CNT02920
      CALL GELIM(L,L,DUMMY(N2),L,P,DUMMY(N3),IFAC,DUMMY(N4),IERR)       CNT02930
      IF( IERR .EQ. 0 ) GO TO 950                                       CNT02940
      CALL LNCNT(4)                                                     CNT02950
      PRINT 925                                                         CNT02960
  925 FORMAT(//' IN CNTREG, GELIM HAS FOUND THE MATRIX W12 TO BE SINGUL CNT02970
     1AR'/)                                                             CNT02980
      RETURN                                                            CNT02990
  950 CONTINUE                                                          CNT03000
      NDUM1(1) = NR(1)                                                  CNT03010
      NDUM1(2) = NA(1)                                                  CNT03020
      CALL MULT(DUMMY,NDUM1,P,NP,F,NF)                                  CNT03030
      IF( IOP(1) .EQ. 0 ) RETURN                                        CNT03040
      CALL PRNT(P,NP,4H P  ,1)                                          CNT03050
      CALL PRNT(F,NF,4H F  ,1)                                          CNT03060
      RETURN                                                            CNT03070
C                                                                       CNT03080
 1000 CONTINUE                                                          CNT03090
      NMAX = T(1)/T(2)                                                  CNT03100
      I = NMAX                                                          CNT03110
      CALL EQUATE(LAMBDA,NA,DUMMY(N2),NA)                               CNT03120
      TT = -T(2)                                                        lNT03130
      N4 = N3+N                                                         CNT03140
      N5 = N4+N                                                         CNT03150
      N6 = N5+N                                                         CNT03160
      N7 = N6+NA(1)                                                     CNT03170
      KSS = 0                                                           CNT03180
      NDUM1(1) = NR(1)                                                  CNT03190
      NDUM1(2) = NA(1)                                                  CNT03200
      CALL EXPSER(DUMMY(N2),NA,DUMMY(N3),NA,TT,KSS,DUMMY(N4))           CNT03210
      CALL EQUATE(DUMMY(N3),NA,DUMMY(N2),NA)                            CNT03220
      IF( IOP(1) .EQ. 0 )  GO TO 1075                                   CNT03230
      CALL LNCNT(3)                                                     CNT03240
      PRINT 1050,T(2)                                                   CNT03250
 1050 FORMAT(//' EXP(-LAMBDA X ',D16.8,')')                             CNT03260
      CALL PRNT(DUMMY(N2),NA,0,3)                                       CNT03270
 1075 CONTINUE                                                          CNT03280
      IF( NMAX .LE. 0 )  RETURN                                         CNT03290
      CALL EQUATE(S,NA,DUMMY(N3),NA)                                    CNT03300
 1100 CONTINUE                                                          CNT03310
      TIME = I*T(2)                                                     CNT03320
      IF( I .NE. NMAX )  CALL EQUATE(DUMMY(N5),NA,P,NP)                 CNT03330
      CALL MULT(DUMMY(N3),NA,DUMMY(N2),NA,DUMMY(N4),NA)                 CNT03340
      CALL MULT(DUMMY(N2),NA,DUMMY(N4),NA,DUMMY(N3),NA)                 CNT03350
      CALL MULT(DUMMY(NW11),NA,DUMMY(N3),NA,DUMMY(N4),NA)               CNT03360
      CALL ADD(DUMMY(NW12),NA,DUMMY(N4),NA,DUMMY(N4),NA)                CNT03370
      CALL TRANP(DUMMY(N4),NA,DUMMY(N5),NA)                             CNT03380
      CALL EQUATE(DUMMY(N5),NA,DUMMY(N4),NA)                            CNT03390
      CALL MULT(DUMMY(NW21),NA,DUMMY(N3),NA,DUMMY(N5),NA)               CNT03400
      CALL ADD(DUMMY(NW22),NA,DUMMY(N5),NA,DUMMY(N5),NA)                CNT03410
      CALL TRANP(DUMMY(N5),NA,DUMMY(N6),NA)                             CNT03420
      CALL EQUATE(DUMMY(N6),NA,DUMMY(N5),NA)                            CNT03430
      L = NA(1)                                                         CNT03440
      IFAC = 0                                                          CNT03450
      CALL GELIM(L,L,DUMMY(N4),L,DUMMY(N5),DUMMY(N6),IFAC,DUMMY(N7),IERRCNT03460
     1)                                                                 CNT03470
      IF( IERR .EQ. 0 ) GO TO 1200                                      CNT03480
      CALL LNCNT(3)                                                     CNT03490
      PRINT 1150,TIME                                                   CNT03500
 1150 FORMAT(//' IN CNTREG AT TIME ',D16.8,' P CANNOT BE COMPUTED DUE T CNT03510
     1O MATRIX SINGULARITY IN GELIM')                                   CNT03520
      RETURN                                                            CNT03530
C                                                                       CNT03540
 1200 CONTINUE                                                          CNT03550
      CALL MAXEL(P,NP,ANORM1)                                           CNT03560
      CALL SUBT(DUMMY(N5),NA,P,NP,DUMMY(N4),NA)                         CNT03570
      CALL MAXEL(DUMMY(N4),NA,ANORM2)                                   CNT03580
      IF( ANORM1 .NE. 0.0 ) GO TO 1225                                  CNT03590
      GO TO 1300                                                        CNT03600
C                                                                       CNT03610
 1225 CONTINUE                                                          CNT03620
      IF(ANORM1 .GT. 1.0 ) GO TO 1250                                   CNT03630
      IF( ANORM2/ANORM1 .LT. RICTCV ) KSS=1                             CNT03640
      GO TO 1300                                                        CNT03650
 1250 CONTINUE                                                          CNT03660
      IF( ANORM2 .LT. RICTCV ) KSS=1                                    CNT03670
C                                                                       CNT03680
 1300 CONTINUE                                                          CNT03690
      CALL MULT(DUMMY,NDUM1,P,NP,F,NF)                                  CNT03700
      IF( IOP(2) .EQ. 0 ) GO TO 1400                                    CNT03710
      CALL LNCNT(5)                                                     CNT03720
      PRINT 1350,TIME                                                   CNT03730
 1350 FORMAT(///' TIME = ',D16.8/)                                      CNT03740
      CALL PRNT(P,NP,4H P  ,1)                                          CNT03750
      IF( I .NE. NMAX )  CALL PRNT(F,NF,4H F  ,1)                       CNT03760
C                                                                       CNT03770
 1400 CONTINUE                                                          CNT03780
      IF( KSS .EQ. 1 ) GO TO 1500                                       CNT03790
      I = I-1                                                           CNT03800
      IF( I .GE. 0 ) GO TO 1100                                         CNT03810
      GO TO 1600                                                        CNT03820
 1500 CONTINUE                                                          CNT03830
      CALL LNCNT(4)                                                     CNT03840
      PRINT 1550                                                        CNT03850
 1550 FORMAT(//' STEADY-STATE SOLUTION HAS BEEN REACHED IN CNTREG'/)    CNT03860
C                                                                       CNT03870
 1600 CONTINUE                                                          CNT03880
      IF( IOP(2) .NE. 0 ) RETURN                                        CNT03890
      IF( IOP(1) .EQ. 0 ) RETURN                                        CNT03900
      CALL LNCNT(5)                                                     CNT03910
      PRINT 1350,TIME                                                   CNT03920
      CALL PRNT(P,NP,4H P  ,1)                                          CNT03930
      CALL PRNT(F,NF,4H F  ,1)                                          CNT03940
C                                                                       CNT03950
      RETURN                                                            lNT03960
      END                                                               CNT03970
      SUBROUTINE EQUATE(A,NA,B,NB)                                      EQU00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         EQU00020
      DIMENSION A(1),B(1),NA(2),NB(2)                                   EQU00030
      NB(1) = NA(1)                                                     EQU00040
      NB(2) =NA(2)                                                      EQU00050
      L=NA(1)*NA(2)                                                     EQU00060
      IF( NA(1) .LT. 1 .OR. L .LT. 1 ) GO TO 999                        EQU00070
      DO 300 I=1,L                                                      EQU00080
  300 B(I)=A(I)                                                         EQU00090
 1000 RETURN                                                            EQU00100
  999 CALL LNCNT (1)                                                    EQU00110
      WRITE  (6,50)  NA                                                 EQU00120
   50 FORMAT  (' DIMENSION ERROR IN EQUATE  NA=',2I6)                   EQU00130
      RETURN                                                            EQU00140
      END                                                               EQU00150
      SUBROUTINE TRANP(A,NA,B,NB)                                       TRA00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         TRA00020
      DIMENSION A(1),B(1),NA(2),NB(2)                                   TRA00030
      NB(1)=NA(2)                                                       TRA00040
      NB(2)=NA(1)                                                       TRA00050
      NR=NA(1)                                                          TRA00060
      NC=NA(2)                                                          TRA00070
      L=NR*NC                                                           TRA00080
      IF( NR .LT. 1 .OR. L .LT. 1  )  GO TO 999                         TRA00090
      IR=0                                                              TRA00100
      DO 300 I=1,NR                                                     TRA00110
      IJ=I-NR                                                           TRA00120
      DO 300 J=1,NC                                                     TRA00130
      IJ=IJ+NR                                                          TRA00140
      IR=IR+1                                                           TRA00150
  300 B(IR)=A(IJ)                                                       TRA00160
      RETURN                                                            TRA00170
  999 CALL LNCNT(1)                                                     TRA00180
      WRITE  (6,50)  NA                                                 TRA00190
   50 FORMAT  (' DIMENSION ERROR IN TRANP   NA=',2I6)                   TRA00200
      RETURN                                                            TRA00210
      END                                                               TRA00220
      SUBROUTINE SCALE (A, NA, B, NB, S)                                SCA00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         SCA00020
      DIMENSION A(1),B(1),NA(2),NB(2)                                   SCA00030
      NB(1) = NA(1)                                                     SCA00040
      NB(2) =NA(2)                                                      SCA00050
      L = NA(1)*NA(2)                                                   SCA00060
      IF( NA(1) .LT. 1 .OR. L .LT. 1 ) GO TO 999                        SCA00070
      DO 300 I=1,L                                                      SCA00080
  300 B(I)=A(I)*S                                                       SCA00090
 1000 RETURN                                                            SCA00100
  999 CALL LNCNT(1)                                                     SCA00110
      WRITE  (6,50) NA                                                  SCA00120
   50 FORMAT  (' DIMENSION ERROR IN SCALE   NA=',2I6)                   SCA00130
      RETURN                                                            SCA00140
      END                                                               SCA00150
      SUBROUTINE UNITY(A,NA)                                            UNI00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         UNI00020
      DIMENSION A(1),NA(2)                                              UNI00030
      IF(NA(1).NE.NA(2)) GO TO 999                                      UNI00040
      L=NA(1)*NA(2)                                                     UNI00050
      DO 100 IT=1,L                                                     UNI00060
  100 A(IT)=0.0                                                         UNI00070
      J = - NA(1)                                                       UNI00080
      NAX = NA(1)                                                       UNI00090
      DO 300 I=1,NAX                                                    UNI00100
      J=NAX +J+1                                                        UNI00110
  300 A(J)=1.                                                           UNI00120
      GO TO 1000                                                        UNI00130
  999 CALL LNCNT (1)                                                    UNI00140
      WRITE(6, 50)(NA(I),I=1,2)                                         UNI00150
   50 FORMAT  (' DIMENSION ERROR IN UNITY   NA=',2I6)                   UNI00160
 1000 RETURN                                                            UNI00170
      END                                                               UNI00180
      SUBROUTINE NULL(A,NA)                                             NUL00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         NUL00020
      DIMENSION A(1)                                                    NUL00030
      DIMENSION NA(2)                                                   NUL00040
      N=NA(1)*NA(2)                                                     NUL00050
      IF( NA(1) .LT. 1 .OR.  N .LT. 1 )  GO TO 999                      NUL00060
      DO 10I=1,N                                                        NUL00070
   10 A(I) = 0.0                                                        NUL00080
      RETURN                                                            NUL00090
C                                                                       NUL00100
  999 CONTINUE                                                          NUL00110
      WRITE (6,50) NA                                                   NUL00120
   50 FORMAT(' DIMENSION ERROR IN NULL  NA =',2I6)                      NUL00130
      RETURN                                                            NUL00140
      END                                                               NUL00150
      SUBROUTINE ADD (A,NA,B,NB,C,NC)                                   ADD00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         ADD00020
      DIMENSION A(1),B(1),C(1),NA(2),NB(2),NC(2)                        ADD00030
      IF( (NA(1) .NE. NB(1)) .OR. (NA(2) .NE. NB(2)) )  GO TO 999       ADD00040
      NC(1)=NA(1)                                                       ADD00050
      NC(2)=NA(2)                                                       ADD00060
      L=NA(1)*NA(2)                                                     ADD00070
      IF( NA(1) .LT. 1  .OR.  L .LT. 1 )  GO TO 999                     ADD00080
      DO 300 I=1,L                                                      ADD00090
  300 C(I)=A(I)+B(I)                                                    ADD00100
      GO TO 1000                                                        ADD00110
  999 CALL LNCNT (1)                                                    ADD00120
      WRITE(6,50) NA,NB                                                 ADD00130
   50 FORMAT  (' DIMENSION ERROR IN ADD     NA=',2I6,5X,'NB=',2I6)      ADD00140
 1000 RETURN                                                            ADD00150
      END                                                               ADD00160
      SUBROUTINE SUBT(A,NA,B,NB,C,NC)                                   SUB00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         SUB00020
      DIMENSION A(1),B(1),C(1),NA(2),NB(2),NC(2)                        SUB00030
      IF((NA(1).NE.NB(1)).OR.(NA(2).NE.NB(2))) GO TO 999                SUB00040
      NC(1)=NA(1)                                                       SUB00050
      NC(2)=NA(2)                                                       SUB00060
      L=NA(1)*NA(2)                                                     SUB00070
      IF( NA(1) .LT. 1 .OR. L .LT. 1 ) GO TO 999                        SUB00080
      DO 300 I=1,L                                                      SUB00090
  300 C(I)=A(I)-B(I)                                                    SUB00100
      GO TO 1000                                                        SUB00110
  999 CALL LNCNT (1)                                                    SUB00120
      WRITE(6,50) NA,NB                                                 SUB00130
   50 FORMAT  (' DIMENSION ERROR IN SUBT    NA=',2I6,5X,'NB=',2I6)      SUB00140
 1000 RETURN                                                            SUB00150
      END                                                               SUB00160
      SUBROUTINE MULT(A,NA,B,NB,C,NC)                                   MUL00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         MUL00020
      DIMENSION A(1),B(1),C(1),NA(2),NB(2),NC(2)                        MUL00030
      NC(1) = NA(1)                                                     MUL00040
      NC(2) = NB(2)                                                     MUL00050
      IF(NA(2).NE.NB(1)) GO TO 999                                      MUL00060
      NAR = NA(1)                                                       MUL00070
      NAC = NA(2)                                                       MUL00080
      NBC = NB(2)                                                       MUL00090
      NAA=NAR*NAC                                                       MUL00100
      NBB=NAR*NBC                                                       MUL00110
      IF ( NAR .LT. 1 .OR. NAA .LT. 1 .OR. NBB .LT. 1 ) GO TO 999       MUL00120
      IR = 0                                                            MUL00130
      IK=-NAC                                                           MUL00140
      DO 350 K=1,NBC                                                    MUL00150
      IK = IK + NAC                                                     MUL00160
      DO 350 J=1,NAR                                                    MUL00170
      IR=IR+1                                                           MUL00180
      IB=IK                                                             MUL00190
      JI=J-NAR                                                          MUL00200
      V1=0.0                                                            MUL00210
      DO 300 I=1,NAC                                                    MUL00220
      JI = JI + NAR                                                     MUL00230
      IB=IB+1                                                           MUL00240
      V3=A(JI)                                                          MUL00250
      V4=B(IB)                                                          MUL00260
      V2=V3*V4                                                          MUL00270
      V1=V1+V2                                                          MUL00280
  300 CONTINUE                                                          MUL00290
      C(IR)=V1                                                          MUL00300
  350 CONTINUE                                                          MUL00310
      GO TO 1000                                                        MUL00320
  999 CALL LNCNT (1)                                                    MUL00330
      WRITE(6,500) (NA(I),I=1,2),(NB(I),I=1,2)                          MUL00340
  500 FORMAT  (' DIMENSION ERROR IN MULT    NA=',2I6,5X,'NB=',2I6)      MUL00350
 1000 RETURN                                                            MUL00360
      END                                                               MUL00370
      SUBROUTINE MAXEL(A,NA,ELMAX)                                      MAX00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         MAX00020
      DIMENSION A(1),NA(2)                                              MAX00030
C                                                                       MAX00040
      N = NA(1)*NA(2)                                                   MAX00050
C                                                                       MAX00060
      ELMAX = DABS( A(1))                                               MAX00070
      DO 100 I = 2,N                                                    MAX00080
      ELMAXI = DABS( A(I) )                                             MAX00090
      IF( ELMAXI .GT. ELMAX )  ELMAX = ELMAXI                           MAX00100
  100 CONTINUE                                                          MAX00110
C                                                                       MAX00120
      RETURN                                                            MAX00130
      END                                                               MAX00140
      SUBROUTINE SNVDEC(IOP,MD,ND,M,N,A,NOS,B,IAC,ZTEST,Q,V,IRANK,APLUS,SNV00010
     1IERR)                                                             SNV00020
      IMPLICIT REAL*8 (A-H,O-Z)                                         SNV00030
      LOGICAL WITHU,WITHV                                               SNV00040
      DIMENSION A(MD,N),V(ND,N),Q(N),E(150)                             SNV00050
      DIMENSION B(MD,NOS),APLUS(ND,M)                                   SNV00060
C                                                                       SNV00070
C                                                                       SNV00080
C     TEST FOR  SCALAR OR VECTOR A                                      SNV00090
C                                                                       SNV00100
      IF( N .GE. 2 ) GO TO 3000                                         SNV00110
C                                                                       SNV00120
      IERR = 0                                                          SNV00130
      ZTEST = 10.**(-IAC)                                               SNV00140
      SUM = 0.0                                                         SNV00150
      DO 1000 I=1,M                                                     SNV00160
      SUM = SUM + A(I,1)*A(I,1)                                         SNV00170
 1000 CONTINUE                                                          SNV00180
      SUM = DSQRT(SUM)                                                  SNV00190
      IRANK = 0                                                         SNV00200
      IF( SUM .GT. ZTEST ) IRANK = 1                                    SNV00210
      Q(1) = SUM                                                        sNV00220
C                                                                       sNV00230
      IF( IOP .EQ. 1) RETURN                                            SNV00240
      V(1,1) = 1.0                                                      sNV00250
      IF( IRANK .EQ. 0 ) GO TO 1200                                     sNV00260
      DO 1100 I =1,M                                                    SNV00270
      A(I,1) = A(I,1)/SUM                                               SNV00280
 1100 CONTINUE                                                          SNV00290
      GO TO 1300                                                        SNV00300
 1200 CONTINUE                                                          SNV00310
      A(1,1) = 1.0                                                      sNV00320
 1300 CONTINUE                                                          SNV00330
C                                                                       SNV00340
      IF( IOP .EQ. 2 ) RETURN                                           SNV00350
      IF( IOP .EQ. 4 ) GO TO 1850                                       SNV00360
      IF( IRANK .EQ. 0 ) GO TO 1600                                     SNV00370
      DO 1500 J = 1,NOS                                                 sNV00380
      Z = 0                                                             SNV00390
      DO 1400 I = 1,M                                                   SNV00400
      Z = Z + A(I,1)*B(I,J)/SUM                                         SNV00410
 1400 CONTINUE                                                          SNV00420
      B(1,J) = Z                                                        SNV00430
 1500 CONTINUE                                                          sNV00440
      GO TO 1800                                                        SNV00450
 1600 CONTINUE                                                          SNV00460
      DO 1700 J =1,NOS                                                  SNV00470
      B(1,J) = 0.0                                                      SNV00480
 1700 CONTINUE                                                          SNV00490
 1800 CONTINUE                                                          sNV00500
C                                                                       sNV00510
      IF( IOP .EQ. 3 ) RETURN                                           SNV00520
 1850 CONTINUE                                                          SNV00530
      IF( IRANK .EQ. 0 ) GO TO 2000                                     SNV00540
      DO 1900 I =1,M                                                    SNV00550
      APLUS(1,I) = A(I,1)/SUM                                           sNV00560
 1900 CONTINUE                                                          SNV00570
      RETURN                                                            SNV00580
 2000 CONTINUE                                                          SNV00590
      DO 2100 I=1,M                                                     SNV00600
      APLUS(1,I) = 0.0                                                  SNV00610
 2100 CONTINUE                                                          SNV00620
      RETURN                                                            SNV00630
C                                                                       SNV00640
C                                                                       SNV00650
 3000 CONTINUE                                                          SNV00660
C                                                                       SNV00670
C                                                                       SNV00680
C                                                                       SNV00690
      TOL=1.0D-60                                                       SNV00700
      SIZE=0.0                                                          SNV00710
      NP1=N+1                                                           SNV00720
C                                                                       SNV00730
C     COMPUTE THE E-NORM OF MATRIX A AS ZERO TEST FOR SINGULAR VALUES   SNV00740
C                                                                       SNV00750
      SUM=0.0                                                           SNV00760
      DO 500 I=1,M                                                      SNV00770
      DO 500 J=1,N                                                      SNV00780
  500 SUM = SUM + A(I,J)**2                                             SNV00790
      ZTEST = DSQRT(SUM)                                                SNV00800
      ZTEST = ZTEST*10.**(-IAC)                                         SNV00810
C                                                                       SNV00820
  510 IF (IOP.NE.1 ) GO TO 515                                          SNV00830
      WITHU=.FALSE.                                                     SNV00840
      WITHV=.FALSE.                                                     SNV00850
      GO TO 520                                                         SNV00860
  515 WITHU=.TRUE.                                                      SNV00870
      WITHV=.TRUE.                                                      SNV00880
  520 CONTINUE                                                          SNV00890
      G = 0.0                                                           SNV00900
      X = 0.0                                                           SNV00910
      DO 30 I = 1,N                                                     SNV00920
C                                                                       SNV00930
C     HOUSEHOLDER REDUCTION TO BIDIAGONAL FORM.                         SNV00940
C                                                                       SNV00950
      E(I) = G                                                          SNV00960
      S = 0.0                                                           SNV00970
      L = I+1                                                           SNV00980
C                                                                       SNV00990
C     ANNIHILATE THE I-TH COLUMN BELOW DIAGONAL.                        SNV01000
C                                                                       SNV01010
      DO 3 J = I,M                                                      SNV01020
    3 S = S + A(J,I)**2                                                 SNV01030
      G = 0.0                                                           SNV01040
      IF(S .LT. TOL)    GO TO 10                                        SNV01050
      G = DSQRT(S)                                                      SNV01060
      F = A(I,I)                                                        SNV01070
      IF(F .GE. 0.0)   G = -G                                           SNV01080
      H = F*G -S                                                        SNV01090
      A(I,I) = F-G                                                      SNV01100
      IF(I .EQ. N)   GO TO 10                                           SNV01110
        DO 9 J = L,N                                                    SNV01120
        S = 0.0                                                         SNV01130
        DO 7 K = I,M                                                    SNV01140
    7   S = S +A(K,I)*A(K,J)                                            SNV01150
        F = S/H                                                         SNV01160
        DO 8 K = I,M                                                    SNV01170
    8   A(K,J) =A(K,J) + F*A(K,I)                                       SNV01180
    9   CONTINUE                                                        SNV01190
   10 Q(I) = G                                                          SNV01200
      IF(I .EQ. N)   GO TO 20                                           SNV01210
C                                                                       SNV01220
C     ANNIHILATE THE I-TH ROW TO RIGHT OF SUPER-DIAG.                   SNV01230
C                                                                       SNV01240
      S = 0.0                                                           SNV01250
      DO 11 J = L,N                                                     SNV01260
   11 S = S + A(I,J)**2                                                 SNV01270
      G = 0.0                                                           SNV01280
      IF (S .LT. TOL)    GO TO 20                                       SNV01290
        G = DSQRT(S)                                                    SNV01300
        F = A(I,I+1)                                                    SNV01310
        IF(F .GE. 0.0)   G = -G                                         SNV01320
        H = F*G -S                                                      SNV01330
        A(I,I+1) = F - G                                                SNV01340
        DO 15 J = L,N                                                   SNV01350
   15   E(J) = A(I,J)/H                                                 sNV01360
        DO 19 J = L,M                                                   SNV01370
        S = 0.0                                                         SNV01380
        DO 16 K = L,N                                                   SNV01390
   16   S = S + A(J,K) * A(I,K)                                         SNV01400
        DO 17 K = L,N                                                   SNV01410
   17   A(J,K) = A(J,K) + S*E(K)                                        SNV01420
   19   CONTINUE                                                        SNV01430
   20 Y = DABS(Q(I)) + DABS(E(I))                                       SNV01440
      IF(Y .GT. SIZE)    SIZE = Y                                       SNV01450
   30 CONTINUE                                                          SNV01460
      IF(.NOT. WITHV)   GO TO 41                                        SNV01470
C                                                                       SNV01480
C     ACCUMULATION OF RIGHT TRANSFORMATIONS.                            SNV01490
C                                                                       SNV01500
      DO 40 II = 1,N                                                    SNV01510
      I = NP1 - II                                                      SNV01520
      IF(I .EQ. N)   GO TO 39                                           SNV01530
      IF(G .EQ. 0.0)   GO TO 37                                         SNV01540
      H = A(I,I+1)*G                                                    SNV01550
      DO 32 J = L,N                                                     SNV01560
   32 V(J,I) = A(I,J)/H                                                 SNV01570
      DO 36 J = L,N                                                     SNV01580
      S = 0.0                                                           SNV01590
      DO 33 K = L,N                                                     SNV01600
   33 S = S + A(I,K)*V(K,J)                                             SNV01610
      DO 34 K = L,N                                                     SNV01620
   34 V(K,J) = V(K,J) + S*V(K,I)                                        SNV01630
   36 CONTINUE                                                          SNV01640
   37 DO 38 J = L,N                                                     SNV01650
      V(I,J) = 0.0                                                      SNV01660
   38 V(J,I) = 0.0                                                      SNV01670
   39 V(I,I) = 1.0                                                      SNV01680
      G = E(I)                                                          SNV01690
   40 L = I                                                             SNV01700
   41 CONTINUE                                                          SNV01710
      IF(.NOT. WITHU)   GO TO 53                                        SNV01720
C                                                                       SNV01730
C     ACCUMULATION OF LEFT TRANSFORMATIONS.                             SNV01740
C                                                                       SNV01750
      DO 52 II = 1,N                                                    SNV01760
      I = NP1 -II                                                       SNV01770
      L = I + 1                                                         SNV01780
      G = Q(I)                                                          SNV01790
      IF(I .EQ. N)   GO TO 43                                           SNV01800
      DO 42 J = L,N                                                     SNV01810
   42 A(I,J) = 0.0                                                      SNV01820
   43 CONTINUE                                                          SNV01830
      IF(G .EQ. 0.0)   GO TO 49                                         SNV01840
      IF(I .EQ. N)   GO TO 47                                           SNV01850
        H = A(I,I)*G                                                    SNV01860
        DO 46 J = L,N                                                   SNV01870
        S = 0.0                                                         SNV01880
        DO 44 K = L,M                                                   SNV01890
   44   S = S + A(K,I)*A(K,J)                                           SNV01900
        F = S/H                                                         SNV01910
        DO 45 K = I,M                                                   SNV01920
   45   A(K,J) = A(K,J) +  F*A(K,I)                                     SNV01930
   46   CONTINUE                                                        SNV01940
   47 DO 48 J = I,M                                                     SNV01950
   48 A(J,I) = A(J,I)/G                                                 SNV01960
      GO TO 51                                                          SNV01970
   49 DO 50 J = I,M                                                     SNV01980
   50 A(J,I) = 0.0                                                      SNV01990
   51 A(I,I) = A(I,I) + 1.0                                             SNV02000
   52 CONTINUE                                                          SNV02010
   53 CONTINUE                                                          sNV02020
C                                                                       SNV02030
C     DIAGONALIZATION OF BIDIAGONAL FORM.                               SNV02040
C                                                                       SNV02050
      DO 100 KK=1,N                                                     SNV02060
        K=NP1-KK                                                        SNV02070
        ITCNT=0                                                         SNV02080
        KP1=K+1                                                         SNV02090
C                                                                       SNV02100
C      TEST F SPLITTING.                                                SNV02110
C                                                                       SNV02120
   59   CONTINUE                                                        SNV02130
        DO 60 LL=1,K                                                    SNV02140
          L=KP1-LL                                                      SNV02150
          IF((SIZE+DABS(E(L))).EQ.SIZE)    GO TO 64                     SNV02160
          LM1=L-1                                                       SNV02170
          IF((SIZE+DABS(Q(LM1))).EQ.SIZE)    GO TO 61                   SNV02180
   60   CONTINUE                                                        SNV02190
C                                                                       sNV02200
C      CANCELLATION OF E(L) IF L .GT. 1.                                SNV02210
C                                                                       SNV02220
   61   C=0.0                                                           SNV02230
        S=1.0                                                           SNV02240
        L1=L-1                                                          SNV02250
        DO 63 I=L,K                                                     SNV02260
          F=S*E(I)                                                      SNV02270
          E(I)=C*E(I)                                                   SNV02280
          IF((SIZE+DABS(F)).EQ.SIZE)   GO TO 64                         SNV02290
          G=Q(I)                                                        SNV02300
          Q(I)=DSQRT(F*F+G*G)                                           SNV02310
          H=Q(I)                                                        SNV02320
          C=G/H                                                         SNV02330
          S=-F/H                                                        SNV02340
          IF(.NOT.WITHU)   GO TO 63                                     SNV02350
            DO 62 J=1,M                                                 SNV02360
              Y=A(J,L1)                                                 SNV02370
              Z=A(J,I)                                                  sNV02380
              A(J,L1)=Y*C+Z*S                                           SNV02390
              A(J,I)= -Y*S+Z*C                                          SNV02400
   62       CONTINUE                                                    SNV02410
C                                                                       SNV02420
   63   CONTINUE                                                        SNV02430
C                                                                       SNV02440
C      TEST F CONVERGENCE.                                              SNV02450
C                                                                       SNV02460
   64 Z=Q(K)                                                            SNV02470
      IF(L.EQ.K)   GO TO 75                                             SNV02480
      IF(ITCNT .LE. 30)   GO TO 65                                      SNV02490
      IERR = KK                                                         SNV02500
      RETURN                                                            SNV02510
   65 ITCNT = ITCNT + 1                                                 SNV02520
C                                                                       SNV02530
C       SHIFT FROM LOWER 2X2.                                           SNV02540
C                                                                       SNV02550
        X=Q(L)                                                          SNV02560
        Y=Q(K-1)                                                        SNV02570
      G=E(K-1)                                                          SNV02580
      H=E(K)                                                            SNV02590
      F=((Y-Z)*(Y+Z)+(G-H)*(G+H))/(2.0*H*Y)                             SNV02600
      G=DSQRT(F*F+1.0)                                                  SNV02610
      IF(F.LT.0.0)  G=-G                                                SNV02620
      F = ((X-Z)*(X+Z)+H*(Y/(F+G)-H))/X                                 SNV02630
C                                                                       SNV02640
C                                                                       SNV02650
C     NEXT QR TRANSFORMATION.                                           SNV02660
C                                                                       SNV02670
      C=1.0                                                             sNV02680
      S=1.0                                                             SNV02690
      LP1=L+1                                                           SNV02700
      DO 73 I=LP1,K                                                     SNV02710
        G=E(I)                                                          SNV02720
        Y=Q(I)                                                          SNV02730
        H=S*G                                                           SNV02740
        G=C*G                                                           SNV02750
        Z=DSQRT(F*F+H*H)                                                SNV02760
        E(I-1)=Z                                                        SNV02770
        C=F/Z                                                           SNV02780
        S=H/Z                                                           SNV02790
        F=X*C+G*S                                                       SNV02800
        G=-X*S+G*C                                                      SNV02810
        H=Y*S                                                           SNV02820
        Y=Y*C                                                           SNV02830
        IF(.NOT.WITHV)   GO TO 70                                       SNV02840
          DO 68 J=1,N                                                   SNV02850
            X=V(J,I-1)                                                  SNV02860
            Z=V(J,I)                                                    SNV02870
            V(J,I-1)=X*C+Z*S                                            SNV02880
            V(J,I)=-X*S+Z*C                                             SNV02890
   68     CONTINUE                                                      SNV02900
C                                                                       SNV02910
   70   Z=DSQRT(F*F+H*H)                                                SNV02920
        Q(I-1)=Z                                                        SNV02930
        C=F/Z                                                           SNV02940
        S=H/Z                                                           SNV02950
        F=C*G+S*Y                                                       SNV02960
        X=-S*G+C*Y                                                      SNV02970
        IF(.NOT.WITHU)   GO TO 73                                       SNV02980
          DO 72 J=1,M                                                   SNV02990
            Y=A(J,I-1)                                                  SNV03000
            Z=A(J,I)                                                    SNV03010
            A(J,I-1)=Y*C+Z*S                                            SNV03020
            A(J,I)=-Y*S+Z*C                                             SNV03030
   72     CONTINUE                                                      SNV03040
C                                                                       SNV03050
C                                                                       SNV03060
   73   E(L) = 0.0                                                      SNV03070
        E(K)=F                                                          SNV03080
        Q(K)=X                                                          SNV03090
        GO TO 59                                                        SNV03100
C                                                                       SNV03110
C       CONVERGENCE.                                                    SNV03120
C                                                                       sNV03130
   75   CONTINUE                                                        SNV03140
        IF(Z.GE.0.0)   GO TO 100                                        SNV03150
          Q(K)=-Z                                                       SNV03160
          IF(.NOT.WITHV) GO TO 100                                      SNV03170
          DO 76 J=1,N                                                   SNV03180
   76 V(J,K)=-V(J,K)                                                    SNV03190
  100 CONTINUE                                                          SNV03200
C                                                                       SNV03210
      IERR=0                                                            SNV03220
      DO 280 II=2,N                                                     SNV03230
      I=II-1                                                            SNV03240
      K=I                                                               SNV03250
      P=Q(I)                                                            SNV03260
      DO 250  J=II,N                                                    SNV03270
      IF (Q(J).LE.P) GO TO 250                                          SNV03280
      K=J                                                               SNV03290
      P=Q(J)                                                            SNV03300
  250 CONTINUE                                                          SNV03310
C                                                                       SNV03320
      IF (K.EQ.I) GO TO 280                                             SNV03330
      Q(K) = Q(I)                                                       SNV03340
      Q(I) = P                                                          SNV03350
C                                                                       SNV03360
      IF(IOP.EQ.1) GO TO 280                                            SNV03370
C                                                                       SNV03380
      DO 260  J=1,N                                                     SNV03390
      P= V(J,I)                                                         SNV03400
      V(J,I)= V(J,K)                                                    SNV03410
      V(J,K)= P                                                         SNV03420
  260 CONTINUE                                                          SNV03430
C                                                                       SNV03440
      DO 270  J=1,M                                                     SNV03450
      P = A(J,I)                                                        SNV03460
      A(J,I)= A(J,K)                                                    SNV03470
      A(J,K)= P                                                         SNV03480
  270 CONTINUE                                                          SNV03490
C                                                                       SNV03500
  280 CONTINUE                                                          SNV03510
C                                                                       SNV03520
      J=N                                                               SNV03530
  290 IF (Q(J).GT.ZTEST) GO TO 300                                      SNV03540
      Q(J)=0.0                                                          SNV03550
      J=J-1                                                             SNV03560
      GO TO 290                                                         SNV03570
  300 IRANK =J                                                          SNV03580
      TEMP = ZTEST/Q(J)                                                 SNV03590
      IF (TEMP.GT..0625)    IERR=-1                                     SNV03600
C                                                                       SNV03610
      IF (IOP.LT. 3)  RETURN                                            SNV03620
      IF(IOP.GT.3) GO TO 170                                            SNV03630
      DO 160  L=1,NOS                                                   SNV03640
      DO 130  J=1,IRANK                                                 SNV03650
      SUM=0.0                                                           SNV03660
      DO 120  I=1,M                                                     SNV03670
  120 SUM =SUM + A(I,J)*B(I,L)                                          SNV03680
  130 E(J)= SUM/Q(J)                                                    SNV03690
C                                                                       SNV03700
      DO 150  K=1,N                                                     SNV03710
      SUM=0.0                                                           SNV03720
      DO 140  I=1,IRANK                                                 SNV03730
  140 SUM =SUM  + V(K,I)*E(I)                                           SNV03740
  150 B(K,L)=SUM                                                        SNV03750
  160 CONTINUE                                                          SNV03760
      RETURN                                                            SNV03770
  170 DO 200  J=1,M                                                     SNV03780
      DO 190  I=1,N                                                     SNV03790
      SUM=0.0                                                           SNV03800
      DO 180  K=1,IRANK                                                 SNV03810
  180 SUM =SUM + V(I,K)*A(J,K)/Q(K)                                     SNV03820
  190 APLUS(I,J)= SUM                                                   SNV03830
  200 CONTINUE                                                          SNV03840
C                                                                       SNV03850
      IF( IOP .EQ.4) RETURN                                             SNV03860
      DO 230  K=1,NOS                                                   SNV03870
      DO 220  I=1,N                                                     SNV03880
      SUM=0.0                                                           SNV03890
      DO 210  J=1,M                                                     SNV03900
  210 SUM=SUM+ APLUS(I,J)*B(J,K)                                        SNV03910
  220 E(I)=SUM                                                          SNV03920
      DO 225  I=1,N                                                     SNV03930
  225 B(I,K)=E(I)                                                       sNV03940
  230 CONTINUE                                                          SNV03950
      RETURN                                                            SNV03960
      END                                                               SNV03970
      SUBROUTINE JUXTR(A,NA,B,NB,C,NC)                                  JUX00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         JUX00020
      DIMENSION A(1),B(1),C(1),NA(2),NB(2),NC(2)                        JUX00030
      IF(NA(2).NE.NB(2))GO TO 600                                       JUX00040
      NC(2)=NA(2)                                                       JUX00050
      NC(1)=NA(1)+NB(1)                                                 JUX00060
      L=NA(1)*NA(2)                                                     JUX00070
      IF( NA(1) .LT. 1 .OR. L .LT. 1 ) GO TO 600                        JUX00080
      IF( NC(2) .LT. 1 ) GO TO 600                                      JUX00090
      MCA=NA(2)                                                         JUX00100
      MRA=NA(1)                                                         JUX00110
      MRB=NB(1)                                                         JUX00120
      MRC=NC(1)                                                         JUX00130
      DO 10 I=1,MCA                                                     JUX00140
      DO 10 J=1,MRA                                                     JUX00150
      K=J+MRA*(I-1)                                                     JUX00160
      L=J+MRC*(I-1)                                                     JUX00170
   10 C(L)=A(K)                                                         JUX00180
      DO 20 I=1,MCA                                                     JUX00190
      DO 20 J=1,MRB                                                     JUX00200
      K=J+MRB*(I-1)                                                     JUX00210
      L=MRA+J+MRC*(I-1)                                                 JUX00220
   20 C(L)=B(K)                                                         JUX00230
      RETURN                                                            JUX00240
  600 CALL LNCNT(1)                                                     JUX00250
      WRITE(6,1600) NA,NB                                               JUX00260
 1600 FORMAT(' DIMENSION ERROR IN JUXTR,  NA=',2I6,5X,'NB=',2I6)        JUX00270
      RETURN                                                            JUX00280
      END                                                               JUX00290
      SUBROUTINE SYMPDS (MAXN,N,A,NRHS,B,IOPT,IFAC,DETERM,ISCALE,P,IERR)SYM00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         SYM00020
      DIMENSION A(MAXN,N),B(MAXN,NRHS),P(N)                             SYM00030
C                                                                       SYM00040
      DATA R1,R2/1.0D+75,1.0D-75/                                       SYM00050
C                                                                       SYM00060
C             TEST FOR A SCALAR MATRIX (IF COEFFICIENT MATRIX IS A      SYM00070
C             SCALAR-- SOLVE  AND COMPUTE DETERMINANT IF DESIRED)       SYM00080
      IERR = 0                                                          SYM00090
      NM1 = N-1                                                         SYM00100
      IF (NM1 .GT. 0) GO TO 20                                          SYM00110
C                                                                       SYM00120
      IF( A(1,1) .LE. 0.0 )  IERR = 1                                   SYM00130
      ISCALE = 0                                                        SYM00140
      DETERM = A(1,1)                                                   SYM00150
      P(1) = 1.0/A(1,1)                                                 SYM00160
      DO 10 J=1,NRHS                                                    SYM00170
      B(1,J) = B(1,J)/DETERM                                            SYM00180
   10 CONTINUE                                                          SYM00190
      RETURN                                                            SYM00200
C                                                                       SyM00210
C             TEST TO DETERMINE IF CHOLESKY DECOMPOSITION OF COEFFICIENTSYM00220
C             MATRIX IS DESIRED                                         SYM00230
   20 IF (IFAC .EQ. 1) GO TO 160                                        SYM00240
C                                                                       SYM00250
C             INITIALIZE DETERMINANT EVALUATION PARAMETERS              SYM00260
      DETERM=1.0                                                        SYM00270
      ISCALE=0                                                          SYM00280
C                                                                       SYM00290
C              'LOOP' TO PERFORM CHOLESKY DECOMPOSTION ON THE COEF-     SYM00300
C             FICIENT MATRIX A (I.E. MATRIX A WILL BE DECOMPOSED INTO   SYM00310
C             THE PRODUCT OF A UNIT LOWER TRIANGULAR MATRIX (L), A      SYM00320
C             DIAGONAL MATRIX (D), AND THE TRANSPOSE OF L (LTRANSPOSE).)SYM00330
C                                                                       SYM00340
   30 DO 150 I=1,N                                                      SYM00350
      IM1 = I-1                                                         SYM00360
C                                                                       SYM00370
      DO 150 J=1,I                                                      SYM00380
      X = A(J,I)                                                        SYM00390
C                                                                       SYM00400
C             DETERMINE IF ELEMENTS ARE ABOVE OR BELOW THE DIAGONAL     SYM00410
      IF (I .GT. J) GO TO 110                                           SYM00420
C                                                                       SYM00430
C             USING THE DIAGONAL ELEMENTS OF MATRIX A, THIS SECTION     SYM00440
C             COMPUTES DIAGONAL MATRIX AND DETERMINES IF MATRIX A IS    SYM00450
C             SYMMETRIC POSITIVE DEFINITE                               SYM00460
      IF (IM1 .EQ. 0) GO TO 50                                          SYM00470
      DO 40 K=1,IM1                                                     SYM00480
      Y = A(I,K)                                                        SYM00490
      A(I,K) = Y*P(K)                                                   SYM00500
      X = X - Y*A(I,K)                                                  SYM00510
   40 CONTINUE                                                          SYM00520
C                                                                       SYM00530
C             TEST IF COEFFICIENT MATRIX IS POSITIVE DEFINITE           SYM00540
   50 IF( X .LE. 0.0 )  IERR = 1                                        SYM00550
C                                                                       SYM00560
C             COMPUTE INVERSE OF DIAGONAL MATRIX D**-1 = 1/P            SYM00570
      P(I) = 1.0 / X                                                    SYM00580
C                                                                       SYM00590
C             TEST TO SEE IF DETERMINANT IS TO BE EVALUATED             SYM00600
      IF (IOPT .EQ. 0) GO TO 150                                        SYM00610
C                                                                       SYM00620
C                                                                       SYM00630
C             SCALE THE DETERMINANT (COMPUTE THE DETERMINANT EVALUATION SYM00640
C             PARAMETERS DETERM AND ISCALE)                             SYM00650
      PIVOTI=X                                                          SYM00660
   60 IF(DABS(DETERM).LT.R1) GO TO 70                                   SYM00670
      DETERM = DETERM*R2                                                SYM00680
      ISCALE = ISCALE+1                                                 SYM00690
      GO TO 60                                                          SYM00700
   70 IF(DABS(DETERM).GT.R2) GO TO 80                                   SYM00710
      DETERM = DETERM*R1                                                SYM00720
      ISCALE = ISCALE-1                                                 SYM00730
      GO TO 70                                                          SYM00740
   80 IF(DABS(PIVOTI).LT.R1) GO TO 90                                   SYM00750
      PIVOTI = PIVOTI*R2                                                SYM00760
      ISCALE = ISCALE+1                                                 SYM00770
      GO TO 80                                                          SYM00780
   90 IF(DABS(PIVOTI).GT.R2) GO TO 100                                  SYM00790
      PIVOTI = PIVOTI*R1                                                SYM00800
      ISCALE = ISCALE-1                                                 SYM00810
      GO TO 90                                                          SYM00820
  100 DETERM = DETERM*PIVOTI                                            SYM00830
      GO TO 150                                                         SYM00840
C                                                                       SYM00850
C                                                                       SYM00860
C             USING THE LOWER TRIANGULAR ELEMENTS OF MATRIX A, THIS     SYM00870
C             SECTION COMPUTES THE UNIT LOWER TRIANGULAR MATRIX         SYM00880
  110 JM1 = J-1                                                         SYM00890
      IF (JM1 .EQ. 0) GO TO 140                                         SYM00900
      DO 120 K=1,JM1                                                    SYM00910
      X = X - A(I,K)*A(J,K)                                             SYM00920
  120 CONTINUE                                                          SYM00930
C                                                                       SYM00940
  140 A(I,J) = X                                                        SYM00950
C                                                                       SYM00960
  150 CONTINUE                                                          SYM00970
C                                                                       SYM00980
C             SECTION TO APPLY BACK SUBSTITUTION TO SOLVE L*Y = B FOR   SYM00990
C             UNIT LOWER TRIANGULAR MATRIX AND CONSTANT COLUMN VECTOR B SYM01000
C                                                                       SYM01010
  160 IF( IFAC .EQ. 2 )  RETURN                                         SYM01020
      DO 180 I=2,N                                                      SYM01030
      IM1=I-1                                                           SYM01040
C                                                                       SYM01050
      DO 180 J=1,NRHS                                                   SYM01060
      X = B(I,J)                                                        SYM01070
C                                                                       SYM01080
      DO 170 K=1,IM1                                                    SYM01090
      X = X - A(I,K)*B(K,J)                                             SYM01100
  170 CONTINUE                                                          SYM01110
C                                                                       SYM01120
      B(I,J) = X                                                        SYM01130
  180 CONTINUE                                                          SYM01140
C                                                                       SYM01150
C             SECTION TO SOLVE (LTRANSROSE)*X = (D**-1)*Y FOR TRANSPOSE SYM01160
C             OF UNIT LOWER TRIANGULAR MATRIX AND INVERSE OF DIAGONAL   SYM01170
C             MATRIX                                                    SYM01180
C                                                                       SYM01190
      Y = P(N)                                                          SYM01200
      DO 190 J=1,NRHS                                                   SYM01210
      B(N,J) = B(N,J)*Y                                                 SYM01220
  190 CONTINUE                                                          SYM01230
C                                                                       SYM01240
  200 I = NM1+1                                                         SYM01250
      Y = P(NM1)                                                        SYM01260
C                                                                       SYM01270
      DO 220 J=1,NRHS                                                   SYM01280
      X = B(NM1,J)*Y                                                    SYM01290
C                                                                       SYM01300
      DO 210 K=I,N                                                      SYM01310
      X = X - A(K,NM1)*B(K,J)                                           SYM01320
  210 CONTINUE                                                          SYM01330
C                                                                       SYM01340
      B(NM1,J) = X                                                      SYM01350
  220 CONTINUE                                                          SYM01360
C                                                                       SyM01370
C                                                                       SYM01380
C             TEST TO DETERMINE IF SOLUTIONS HAVE BEEN DETERMINED FOR   SYM01390
C             ALL COLUMN VECTORS                                        SYM01400
      NM1 = NM1-1                                                       SYM01410
      IF (NM1 .GT. 0) GO TO 200                                         SYM01420
C                                                                       SYM01430
      RETURN                                                            SYM01440
      END                                                               SYM01450
      SUBROUTINE EXPSER(A,NA,EXPA,NEXPA,T,IOP,DUMMY)                    EXP00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         EXP00020
      DIMENSION A(1),EXPA(1),DUMMY(1)                                   EXP00030
      DIMENSION NA(2),NEXPA(2)                                          EXP00040
      COMMON/CONV/SUMCV,RICTCV,SERCV,MAXSUM                             EXP00050
C                                                                       EXP00060
      N = NA(1)                                                         EXP00070
      L = (N**2) + 1                                                    EXP00080
      TT = T                                                            ExP00090
      NEXPA(1)=NA(1)                                                    EXP00100
      NEXPA(2)=NA(2)                                                    EXP00110
C                                                                       EXP00120
      CALL MAXEL(A,NA,ANAA)                                             EXP00130
      ANAA = ANAA*TT                                                    EXP00140
      ANAA = DABS(ANAA)                                                 EXP00150
      IF( ANAA .GT. 1.E-15 ) GO TO 100                                  EXP00160
      CALL UNITY(EXPA,NEXPA)                                            EXP00170
      GO TO 800                                                         EXP00180
C                                                                       EXP00190
  100 CONTINUE                                                          EXP00200
      IOPT=2                                                            EXP00210
      CALL NORMS(N,N,N,A,IOPT,ZERO)                                     EXP00220
      ZERO=ZERO/(2.**47)                                                EXP00230
      CALL TRCE(A,NA,TR)                                                EXP00240
      TR = TR/N                                                         EXP00250
      DO 200 I =1,N                                                     EXP00260
      M =I+N*(I-1)                                                      EXP00270
      A(M) = A(M) - TR                                                  EXP00280
  200 CONTINUE                                                          EXP00290
C                                                                       EXP00300
      IOPT = 1                                                          EXP00310
      CALL NORMS(N,N,N,A,IOPT,COL)                                      EXP00320
      IOPT = 3                                                          EXP00330
      CALL NORMS(N,N,N,A,IOPT,ROW)                                      EXP00340
      ANORM = ROW                                                       EXP00350
      IF( ANORM .GT. COL )  ANORM = COL                                 EXP00360
      TMAX = 1./ANORM                                                   EXP00370
      K= 0                                                              EXP00380
  300 CONTINUE                                                          EXP00390
      IF( TMAX - TT ) 325,350,350                                       EXP00400
  325 CONTINUE                                                          EXP00410
      K=K+1                                                             EXP00420
      TT = T/(2**K)                                                     EXP00430
      IF( K - 1000 ) 300,700,700                                        EXP00440
  350 CONTINUE                                                          EXP00450
      SC = TT                                                           EXP00460
      CALL SCALE(A,NA,A,NA,TT)                                          EXP00470
      CALL UNITY(EXPA,NEXPA)                                            EXP00480
      II = 2                                                            EXP00490
      CALL ADD(A,NA,EXPA,NEXPA,DUMMY,NA)                                EXP00500
      CALL EQUATE(A,NA,DUMMY(L),NA)                                     EXP00510
  400 CONTINUE                                                          EXP00520
      CALL MULT(A,NA,DUMMY(L),NA,EXPA,NEXPA)                            EXP00530
      S = 1./II                                                         EXP00540
      CALL SCALE(EXPA,NEXPA,DUMMY(L),NA,S)                              EXP00550
      CALL ADD(DUMMY(L),NA,DUMMY,NA,EXPA,NEXPA)                         EXP00560
      CALL MAXEL(DUMMY,NA,TOT)                                          EXP00570
      CALL MAXEL(DUMMY(L),NA,DELT)                                      EXP00580
      IF( TOT .GT. 1.0 ) GO TO 500                                      EXP00590
      IF( DELT/TOT .LT. SERCV )  GO TO 600                              EXP00600
      GO TO 550                                                         EXP00610
  500 CONTINUE                                                          EXP00620
      IF( DELT .LT. SERCV )  GO TO 600                                  EXP00630
  550 CONTINUE                                                          EXP00640
      CALL EQUATE(EXPA,NEXPA,DUMMY,NA)                                  EXP00650
      II = II + 1                                                       EXP00660
      GO TO 400                                                         EXP00670
C                                                                       EXP00680
  600 CONTINUE                                                          EXP00690
      IF( K ) 625,675,650                                               EXP00700
  625 CONTINUE                                                          EXP00710
      CALL LNCNT(1)                                                     EXP00720
      PRINT 635                                                         EXP00730
  635 FORMAT( '   ERROR IN EXPSER,  K IS NEGATIVE ' )                   EXP00740
      RETURN                                                            EXP00750
C                                                                       ExP00760
  650 CONTINUE                                                          EXP00770
      DO 660 I =1,K                                                     EXP00780
      TT = 2*TT                                                         EXP00790
      CALL EQUATE(EXPA,NEXPA,DUMMY,NA)                                  EXP00800
      CALL EQUATE(DUMMY,NA,DUMMY(L),NA)                                 EXP00810
      CALL MULT(DUMMY(L),NA,DUMMY,NA,EXPA,NEXPA)                        EXP00820
  660 CONTINUE                                                          EXP00830
      T = TT                                                            EXP00840
  675 CONTINUE                                                          EXP00850
      S = 1./SC                                                         EXP00860
      CALL SCALE(A,NA,A,NA,S)                                           EXP00870
      DO 685 I = 1,N                                                    EXP00880
      M = I + N*(I-1)                                                   EXP00890
      A(M) = A(M) + TR                                                  EXP00900
      IF( DABS(A(M)) .LE. ZERO )  A(M) = 0.0                            EXP00910
  685 CONTINUE                                                          EXP00920
C                                                                       EXP00930
      TR=TR*T                                                           ExP00940
      S =  DEXP(TR)                                                     EXP00950
      CALL SCALE(EXPA,NEXPA,EXPA,NEXPA,S)                               EXP00960
      GO TO 800                                                         EXP00970
C                                                                       EXP00980
  700 CONTINUE                                                          EXP00990
      CALL LNCNT(1)                                                     EXP01000
      PRINT 750                                                         EXP01010
  750 FORMAT('  ERROR IN EXPSER,  K = 1000 ')                           EXP01020
      RETURN                                                            EXP01030
C                                                                       EXP01040
  800 CONTINUE                                                          EXP01050
      IF( IOP .EQ. 0 ) RETURN                                           EXP01060
      CALL LNCNT(4)                                                     EXP01070
      PRINT 825                                                         EXP01080
  825 FORMAT(//' COMPUTATION OF THE MATRIX EXPONENTIAL EXP(A T) BY THE SEXP01090
     1ERIES METHOD '/)                                                  EXP01100
      CALL PRNT(A,NA,4H A  ,1)                                          EXP01110
      CALL LNCNT(3)                                                     EXP01120
      PRINT 850,T                                                       EXP01130
  850 FORMAT(/' T = ',D16.8/)                                           EXP01140
      CALL PRNT(EXPA,NEXPA,4HEXPA,1)                                    EXP01150
      RETURN                                                            EXP01160
      END                                                               EXP01170
      SUBROUTINE TRCE  (A,NA,TR)                                        TRC00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         tRC00020
      DIMENSION A(1)                                                    TRC00030
      DIMENSION NA(2)                                                   TRC00040
      IF (NA(1).NE.NA(2)) GO TO 600                                     TRC00050
      N=NA(1)                                                           TRC00060
      TR=0.0                                                            tRC00070
      IF( N .LT. 1 ) GO TO 600                                          TRC00080
      DO 10 I=1,N                                                       TRC00090
      M=I+N*(I-1)                                                       TRC00100
   10 TR=TR+A(M)                                                        TRC00110
      RETURN                                                            TRC00120
  600 CALL LNCNT(1)                                                     TRC00130
      WRITE (6,1600) NA                                                 TRC00140
 1600 FORMAT (' TRACE REQUIRES SQUARE MATRIX    NA=',2I6)               TRC00150
      RETURN                                                            TRC00160
      END                                                               TRC00170
      SUBROUTINE NORMS(MAXROW,M,N,A,IOPT,RLNORM)                        NOR00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         NOR00020
      DIMENSION A(1)                                                    NOR00030
C                                                                       NOR00040
C  INITIALIZATION                                                       NOR00050
C                                                                       NOR00060
      RLNORM=0.                                                         NOR00070
      SUM=0.                                                            NOR00080
      I=-MAXROW                                                         NOR00090
C                                                                       NOR00100
C  TRANSFER TO APPROPRIATE LOOP TO COMPUTE THE DESIRED NORM             NOR00110
C                                                                       NOR00120
      IF(IOPT-2)5,20,30                                                 NOR00130
C                                                                       NOR00140
C  THIS LOOP COMPUTES THE ONE-NORM                                      NOR00150
C                                                                       NOR00160
    5 DO 15 K=1,N                                                       NOR00170
      I=I+MAXROW                                                        NOR00180
      DO 10 J=1,M                                                       NOR00190
      L=I+J                                                             NOR00200
   10 SUM=DABS(A(L))+SUM                                                NOR00210
      IF(SUM.GT.RLNORM)RLNORM=SUM                                       NOR00220
   15 SUM=0.                                                            NOR00230
      RETURN                                                            NOR00240
C                                                                       NOR00250
C  THIS LOOP COMPUTES THE EUCLIDEAN NORM                                NOR00260
C                                                                       NOR00270
   20 DO 25 K=1,N                                                       NOR00280
      I=I+MAXROW                                                        NOR00290
      DO 25 J=1,M                                                       NOR00300
      L=I+J                                                             NOR00310
      SUM=A(L)                                                          NOR00320
   25 RLNORM=SUM*SUM+RLNORM                                             NOR00330
      RLNORM=DSQRT(RLNORM)                                              NOR00340
      RETURN                                                            NOR00350
C                                                                       NOR00360
C  THIS LOOP COMPUTES THE INFINITY-NORM                                 NOR00370
C                                                                       NOR00380
   30 DO 40 J=1,M                                                       NOR00390
      L=I+J                                                             NOR00400
      DO 35 K=1,N                                                       NOR00410
      L=L+MAXROW                                                        NOR00420
   35 SUM=DABS(A(L))+SUM                                                NOR00430
      IF(SUM.GT.RLNORM)RLNORM=SUM                                       NOR00440
   40 SUM=0.                                                            NOR00450
      RETURN                                                            NOR00460
      END                                                               NOR00470
      SUBROUTINE  PRNT(A,NA,NAM,IOP)                                    PRN00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         PRN00020
      DIMENSION A(1),NA(2)                                              PRN00030
      COMMON  /FORM/FMT1(2),FMT2(2),NEPR                                PRN00040
      COMMON/LINES/TITLE(10),TIL(3),NLP,LIN                             PRN00050
C- NOTE NLP NO. LINES/PAGE VARIES WITH THE INSTALLATION.                PRN00060
      DATA KZ,KW,KB /1H0,1H1,1H /                                       PRN00070
      NAME = NAM                                                        PRN00080
      II = IOP                                                          PRN00090
      NR = NA(1)                                                        PRN00100
      NC = NA(2)                                                        PRN00110
      NLST = NR * NC                                                    PRN00120
      IF( NLST .LT. 1 .OR. NR .LT. 1 ) GO TO 16                         PRN00130
      IF(NAME  .EQ. 0) NAME = KB                                        PRN00140
C- SKIP HEADLINE IF REQUESTED.                                          PRN00150
      GO TO (11,10,132,12),       II                                    PRN00160
   10 CALL LNCNT(100)                                                   PRN00170
   11 CALL LNCNT(2)                                                     PRN00180
    3 WRITE(6,177) KZ,NAME,NR,NC                                        PRN00190
177   FORMAT(A1,5X,A4,8H  MATRIX,5X,I3,5H ROWS,5X,I3,8H COLUMNS)        PRN00200
      GO TO 13                                                          PRN00210
   12 CALL LNCNT(100)                                                   PRN00220
      GO TO 13                                                          PRN00230
  132 CALL LNCNT(2)                                                     PRN00240
      WRITE (6,891)                                                     PRN00250
  891 FORMAT (1H0)                                                      PRN00260
C- BELOW COMPUTE NR OF LINES/ ROW --DECIDE IF 1 EXTRA BLANK LINE        PRN00270
   13 J=(NC-1)/NEPR+1                                                   PRN00280
C- WHY ALWAYS ADD 1 LINE- BECAUSE IF MULTIPLE, USE 1 BLK LINE EXTRA.    PRN00290
      NLPW = J                                                          PRN00300
      JST = 1                                                           PRN00310
C- COMPUTE LAST ROW POSITION -1 BELOW                                   PRN00320
      NLST = NLST -NR                                                   PRN00330
      MN=NC                                                             PRN00340
      IF  (NC.GT.NEPR)   MN=NEPR                                        PRN00350
      KLST=NR*(MN-1)                                                    PRN00360
91    CONTINUE                                                          PRN00370
      DO 912 J = JST, NR                                                PRN00380
      CALL LNCNT(NLPW)                                                  PRN00390
      KLST = KLST +1                                                    PRN00400
      WRITE (6,FMT1) (A(N), N=J,KLST,NR)                                PRN00410
      IF  (NC.LE.NEPR)   GO TO 912                                      PRN00420
      NLST = NLST +1                                                    PRN00430
      KNR=KLST+NR                                                       PRN00440
      WRITE (6,FMT2) (A(N), N=KNR,NLST,NR)                              PRN00450
912   CONTINUE                                                          PRN00460
      RETURN                                                            PRN00470
   16 CALL LNCNT(1)                                                     PRN00480
      WRITE (6,916) NAM,NA                                              PRN00490
  916 FORMAT  (' ERROR IN PRNT  MATRIX ',A4,' HAS NA=',2I6)             PRN00500
      RETURN                                                            PRN00510
      END                                                               PRN00520
      SUBROUTINE EIGEN(MAX, N, A, ER, EI, ISV, ILV, V, WK, IERR)        EIG00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         EIG00020
      DIMENSION A(MAX,N),ER(N),EI(N),V(MAX,1),WK(N,1)                   EIG00030
      INTEGER INT(20)                                                   EIG00040
      LOGICAL*1 SELECT(25)                                              EIG00050
C                                                                       EIG00060
C     PRELIMINARY REDUCTION                                             EIG00070
C                                                                       EIG00080
      CALL BALANC (MAX,N,A,LOW,IGH,WK)                                  EIG00090
      CALL ELMHES (MAX,N,LOW,IGH,A,INT(1))                              EIG00100
      IV = ISV + ILV                                                    EIG00110
      IF (IV .NE. 0) GO TO 10                                           EIG00120
C                                                                       EIG00130
C     COMPUTE ALL EIGENVALUES AND NO EIGENVECTORS                       EIG00140
C                                                                       EIG00150
      CALL HQR (MAX,N,LOW,IGH,A,ER,EI,IERR)                             EIG00160
      IF (IERR .NE. 0) GO TO 260                                        EIG00170
      DO 5 I=1,N                                                        EIG00180
         WK(I,1) = ER(I)                                                EIG00190
         WK(I,2) = EI(I)                                                EIG00200
         WK(I,3) = ER(I)**2 + EI(I)**2                                  EIG00210
  5   CONTINUE                                                          EIG00220
      IC = 0                                                            EIG00230
      GO TO 190                                                         EIG00240
  10  CONTINUE                                                          EIG00250
C                                                                       EIG00260
C     SAVE A MATRIX FOR INVERSE ITERATION AND INITIALIZE WK(I,4)        EIG00270
C       ARRAY WHICH WILL BE A LOGICAL ARRAY IN CALLED SUBROUTINES       EIG00280
C                                                                       EIG00290
      DO 20 I=1,N                                                       EIG00300
      SELECT(I)=.FALSE.                                                 EIG00310
         JS = 1                                                         EIG00320
         IF (I .GE. 3) JS = I-1                                         EIG00330
         DO 20 J=JS,N                                                   EIG00340
            WK(I,J+5) = A(I,J)                                          EIG00350
  20  CONTINUE                                                          EIG00360
C                                                                       EIG00370
C     COMPUTE ALL EIGENVALUES (UNORDERED)                               EIG00380
C                                                                       EIG00390
      CALL HQR (N,N,LOW,IGH,WK(1,6),ER,EI,IERR)                         EIG00400
      IF (IERR .NE. 0) GO TO 260                                        EIG00410
      DO 30 I=1,N                                                       EIG00420
         WK(I,3) = ER(I)**2 + EI(I)**2                                  EIG00430
  30  CONTINUE                                                          EIG00440
      IF (ILV .EQ. 0) GO TO 60                                          EIG00450
C                                                                       EIG00460
C     FIND LARGEST ILV EIGENVALUES AND FLAG THEM                        EIG00470
C                                                                       EIG00480
      DO 50 I=1,ILV                                                     EIG00490
         P = -1.D0                                                      EIG00500
         DO 40 J=1,N                                                    EIG00510
            IF (WK(J,3) .LE. P) GO TO 40                                EIG00520
            K = J                                                       EIG00530
            P = WK(J,3)                                                 EIG00540
  40     CONTINUE                                                       EIG00550
      SELECT(K)=.TRUE.                                                  EIG00560
         WK(K,3) = -WK(K,3)                                             EIG00570
  50  CONTINUE                                                          EIG00580
      IF (EI(K) .EQ. 0.) GO TO 60                                       EIG00590
      IF (EI(K) .GT. 0.) GO TO 55                                       EIG00600
      IF (SELECT(K-1))GO TO 60                                          EIG00610
      ILV = ILV+1                                                       EIG00620
      SELECT(K-1)=.TRUE.                                                EIG00630
      GO TO 60                                                          EIG00640
  55  CONTINUE                                                          EIG00650
      IF (.NOT.SELECT(K+1)) ILV = ILV+1                                 EIG00660
  60  CONTINUE                                                          EIG00670
      IF (ISV .EQ. 0) GO TO 90                                          EIG00680
C                                                                       EIG00690
C     FIND SMALLEST ISV EIGENVALUES AND FLAG THEM                       EIG00700
C                                                                       EIG00710
      DO 65 I=1,N                                                       EIG00720
         WK(I,3) = DABS(WK(I,3))                                        EIG00730
  65  CONTINUE                                                          EIG00740
      DO 80 I=1,ISV                                                     EIG00750
         P = 1.D74                                                      EIG00760
         DO 70 J=1,N                                                    EIG00770
            IF (WK(J,3) .GE. P) GO TO 70                                EIG00780
            K = J                                                       EIG00790
            P = WK(J,3)                                                 EIG00800
  70     CONTINUE                                                       EIG00810
      SELECT(K)=.TRUE.                                                  EIG00820
         WK(K,3) = 1.D74                                                EIG00830
  80  CONTINUE                                                          EIG00840
      IF (EI(K) .EQ. 0.) GO TO 90                                       EIG00850
      IF (EI(K) .GT. 0.) GO TO 85                                       EIG00860
      IF (SELECT(K-1)) GO TO 90                                         EIG00870
      ISV = ISV+1                                                       EIG00880
      SELECT(K-1)=.TRUE.                                                EIG00890
      GO TO 90                                                          EIG00900
  85  CONTINUE                                                          EIG00910
      IF (.NOT.SELECT(K+1)) ISV = ISV+1                                 EIG00920
  90  CONTINUE                                                          EIG00930
C                                                                       EIG00940
C     FIND EIGENVECTORS FOR FLAGGED EIGENVALUES                         EIG00950
C                                                                       EIG00960
      CALL INVIT (MAX,N,A,ER,EI,SELECT,N,M,V,IERR,WK(1,6),WK(1,3),      EIG00970
     1            WK(1,5))                                              EIG00980
C                                                                       EIG00990
C     BACK TRANSFORM EIGENVECTORS TO ORIGINAL MATRIX                    EIG01000
C                                                                       EIG01010
      CALL ELMBAK (MAX,LOW,IGH,A,INT(1) ,M,V)                           EIG01020
      CALL BALBAK (MAX,N,LOW,IGH,WK,M,V)                                EIG01030
C                                                                       EIG01040
C     SEPARATE FLAGGED EIGENVALUES FROM UNFLAGGED EIGENVALUES           EIG01050
C                                                                       EIG01060
      IV = ISV + ILV                                                    EIG01070
      IF (IV .LE. N) GO TO 100                                          EIG01080
      ILV = N-ISV                                                       EIG01090
      IV = N                                                            EIG01100
 100  CONTINUE                                                          EIG01110
      IC = 0                                                            EIG01120
      JC = IV                                                           EIG01130
      DO 150 I=1,N                                                      EIG01140
         IF (SELECT(I)) GO TO 120                                       EIG01150
         IF (EI(I) .GE. 0.) GO TO 110                                   EIG01160
         IF (SELECT(I-1)) GO TO 120                                     EIG01170
 110     CONTINUE                                                       EIG01180
         JC = JC+1                                                      EIG01190
         WK(JC,1) = ER(I)                                               EIG01200
         WK(JC,2) = EI(I)                                               EIG01210
         KC = JC                                                        EIG01220
         GO TO 130                                                      EIG01230
 120     CONTINUE                                                       EIG01240
         IC = IC+1                                                      EIG01250
         WK(IC,1) = ER(I)                                               EIG01260
         WK(IC,2) = EI(I)                                               EIG01270
         KC = IC                                                        EIG01280
 130     CONTINUE                                                       EIG01290
         WK(KC,3) = ER(I)**2 + EI(I)**2                                 EIG01300
 150  CONTINUE                                                          EIG01310
C                                                                       EIG01320
C     NORMALIZE VECTORS TO UNIT LENGTH AND STORE FOR REORDERING         EIG01330
C                                                                       EIG01340
      J = 0                                                             EIG01350
 151  CONTINUE                                                          EIG01360
      J = J+1                                                           EIG01370
      IF (WK(J,2) .NE. 0.) GO TO 154                                    EIG01380
      SUM = 0.                                                          EIG01390
      DO 152 I=1,N                                                      EIG01400
         SUM = SUM + V(I,J)**2                                          EIG01410
 152  CONTINUE                                                          EIG01420
      IF (SUM .EQ. 0.) GO TO 158                                        EIG01430
      SUM = DSQRT(SUM)                                                  EIG01440
      DO 153 I=1,N                                                      EIG01450
         WK(I,J+4) = V(I,J)/SUM                                         EIG01460
 153  CONTINUE                                                          EIG01470
      GO TO 158                                                         EIG01480
 154  CONTINUE                                                          EIG01490
      JP1 = J+1                                                         EIG01500
      SUM = 0.                                                          EIG01510
      DO 155 I=1,N                                                      EIG01520
         SUM = SUM + V(I,J)**2 + V(I,JP1)**2                            EIG01530
 155  CONTINUE                                                          EIG01540
      IF (SUM .EQ. 0.) GO TO 157                                        EIG01550
      SUM = DSQRT(SUM)                                                  EIG01560
      DO 156 I=1,N                                                      EIG01570
         WK(I,J+4) = V(I,J)/SUM                                         EIG01580
         WK(I,J+5) = V(I,JP1)/SUM                                       EIG01590
 156  CONTINUE                                                          EIG01600
 157  CONTINUE                                                          EIG01610
      J = JP1                                                           EIG01620
 158  CONTINUE                                                          EIG01630
      IF (J .LT. IV) GO TO 151                                          EIG01640
      IC = 0                                                            EIG01650
      LC = 0                                                            EIG01660
      IF (ISV .EQ. 0) GO TO 190                                         EIG01670
C                                                                       EIG01680
C     ORDER SMALLEST ISV EIGENVALUES AND EIGENVECTORS FOR OUTPUT        EIG01690
C                                                                       EIG01700
      DO 180 I=1,ISV                                                    EIG01710
         P = 1.D74                                                      EIG01720
         DO 160 J=1,IV                                                  EIG01730
            IF (WK(J,3) .GE. P) GO TO 160                               EIG01740
            K = J                                                       EIG01750
            P = WK(J,3)                                                 EIG01760
 160     CONTINUE                                                       EIG01770
         IC = IC+1                                                      EIG01780
         LC = LC+1                                                      EIG01790
         ER(IC) = WK(K,1)                                               EIG01800
         EI(IC) = WK(K,2)                                               EIG01810
         DO 170 J=1,N                                                   EIG01820
            V(J,LC) = WK(J,K+4)                                         EIG01830
 170     CONTINUE                                                       EIG01840
         WK(K,3) = 1.D74                                                EIG01850
 180  CONTINUE                                                          EIG01860
 190  CONTINUE                                                          EIG01870
      IF (IV .EQ. N) GO TO 220                                          EIG01880
C                                                                       EIG01890
C     ORDER UNFLAGGED EIGENVALUES FOR OUTPUT                            EIG01900
C                                                                       EIG01910
      IV1 = IV+1                                                        EIG01920
      IUF = N - IV                                                      EIG01930
      DO 210 I=1,IUF                                                    EIG01940
         P = 1.D74                                                      EIG01950
         DO 200 J=IV1,N                                                 EIG01960
            IF (WK(J,3) .GE. P) GO TO 200                               EIG01970
            K = J                                                       EIG01980
            P = WK(J,3)                                                 EIG01990
 200     CONTINUE                                                       EIG02000
         IC = IC+1                                                      EIG02010
         ER(IC) = WK(K,1)                                               EIG02020
         EI(IC) = WK(K,2)                                               EIG02030
         WK(K,3) = 1.D74                                                EIG02040
 210  CONTINUE                                                          EIG02050
 220  CONTINUE                                                          EIG02060
      IF (ILV .EQ. 0) GO TO 260                                         EIG02070
C                                                                       EIG02080
C     ORDER LARGEST ILV EIGENVALUES AND EIGENVECTORS FOR OUTPUT         EIG02090
C                                                                       EIG02100
      DO 250 I=1,ILV                                                    EIG02110
         P = 1.D74                                                      EIG02120
         DO 230 J=1,IV                                                  EIG02130
            IF (WK(J,3) .GE. P) GO TO 230                               EIG02140
            K = J                                                       EIG02150
            P = WK(J,3)                                                 EIG02160
 230     CONTINUE                                                       EIG02170
         IC = IC+1                                                      EIG02180
         LC = LC+1                                                      EIG02190
         ER(IC) = WK(K,1)                                               EIG02200
         EI(IC) = WK(K,2)                                               EIG02210
         DO 240 J=1,N                                                   EIG02220
            V(J,LC) = WK(J,K+4)                                         EIG02230
 240     CONTINUE                                                       EIG02240
         WK(K,3) = 1.D74                                                EIG02250
 250  CONTINUE                                                          EIG02260
 260  CONTINUE                                                          EIG02270
      RETURN                                                            EIG02280
      END                                                               EIG02290
      SUBROUTINE BALANC(NM,N,A,LOW,IGH,SCALE)                           BAL00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         BAL00020
      INTEGER I,J,K,L,M,N,JJ,NM,IGH,LOW,IEXC                            BAL00030
      DIMENSION A(NM,N),SCALE(N)                                        BAL00040
C     REAL C,F,G,R,S,B2,RADIX                                           BAL00050
C     REAL DABS                                                         BAL00060
      LOGICAL NOCONV                                                    BAL00070
C                                                                       BAL00080
C                                                                       BAL00090
C     ********** RADIX IS A MACHINE DEPENDENT PARAMETER SPECIFYING      BAL00100
C                THE BASE OF THE MACHINE FLOATING POINT REPRESENTATION. BAL00110
C                                                                       BAL00120
C                                                                       BAL00130
      RADIX = 16.                                                       BAL00140
C                                                                       BAL00150
      B2 = RADIX * RADIX                                                BAL00160
      K = 1                                                             BAL00170
      L = N                                                             BAL00180
      GO TO 100                                                         BAL00190
C     ********** IN-LINE PROCEDURE FOR ROW AND                          BAL00200
C                COLUMN EXCHANGE **********                             BAL00210
   20 SCALE(M) = J                                                      BAL00220
      IF (J .EQ. M) GO TO 50                                            BjL00230
C                                                                       BAL00240
      DO 30 I = 1, L                                                    BAL00250
         F = A(I,J)                                                     BAL00260
         A(I,J) = A(I,M)                                                BAL00270
         A(I,M) = F                                                     BAL00280
   30 CONTINUE                                                          BAL00290
C                                                                       BAL00300
      DO 40 I = K, N                                                    BAL00310
         F = A(J,I)                                                     BAL00320
         A(J,I) = A(M,I)                                                BAL00330
         A(M,I) = F                                                     BAL00340
   40 CONTINUE                                                          BAL00350
C                                                                       BAL00360
   50 GO TO (80,130), IEXC                                              BAL00370
C     ********** SEARCH FOR ROWS ISOLATING AN EIGENVALUE                BAL00380
C                AND PUSH THEM DOWN **********                          BAL00390
   80 IF (L .EQ. 1) GO TO 280                                           BAL00400
      L = L - 1                                                         BAL00410
C     ********** FOR J=L STEP -1 UNTIL 1 DO -- **********               BAL00420
  100 DO 120 JJ = 1, L                                                  BAL00430
         J = L + 1 - JJ                                                 BAL00440
C                                                                       BAL00450
         DO 110 I = 1, L                                                BAL00460
            IF (I .EQ. J) GO TO 110                                     BAL00470
            IF (A(J,I) .NE. 0.0D0) GO TO 120                            BAL00480
  110    CONTINUE                                                       BAL00490
C                                                                       BAL00500
         M = L                                                          BAL00510
         IEXC = 1                                                       BAL00520
         GO TO 20                                                       BAL00530
  120 CONTINUE                                                          BAL00540
C                                                                       BAL00550
      GO TO 140                                                         BAL00560
C     ********** SEARCH FOR COLUMNS ISOLATING AN EIGENVALUE             BAL00570
C                AND PUSH THEM LEFT **********                          BAL00580
  130 K = K + 1                                                         BAL00590
C                                                                       BjL00600
  140 DO 170 J = K, L                                                   BAL00610
C                                                                       BAL00620
         DO 150 I = K, L                                                BAL00630
            IF (I .EQ. J) GO TO 150                                     BAL00640
            IF (A(I,J) .NE. 0.0D0) GO TO 170                            BjL00650
  150    CONTINUE                                                       BAL00660
C                                                                       BAL00670
         M = K                                                          BAL00680
         IEXC = 2                                                       BAL00690
         GO TO 20                                                       BAL00700
  170 CONTINUE                                                          BAL00710
C     ********** NOW BALANCE THE SUBMATRIX IN ROWS K TO L **********    BAL00720
      DO 180 I = K, L                                                   BAL00730
  180 SCALE(I) = 1.0D0                                                  BAL00740
C     ********** ITERATIVE LOOP FOR NORM REDUCTION **********           BjL00750
  190 NOCONV = .FALSE.                                                  BAL00760
C                                                                       BAL00770
      DO 270 I = K, L                                                   BjL00780
         C = 0.0D0                                                      BAL00790
         R = 0.0D0                                                      BAL00800
C                                                                       BAL00810
         DO 200 J = K, L                                                BAL00820
            IF (J .EQ. I) GO TO 200                                     BAL00830
            C = C + DABS(A(J,I))                                        BAL00840
            R = R + DABS(A(I,J))                                        BAL00850
  200    CONTINUE                                                       BAL00860
C     ********** GUARD AGAINST ZERO C OR R DUE TO UNDERFLOW **********  BAL00870
         IF (C .EQ. 0.0D0 .OR. R .EQ. 0.0D0) GO TO 270                  BAL00880
         G = R / RADIX                                                  BAL00890
         F = 1.0D0                                                      BAL00900
         S = C + R                                                      BAL00910
  210    IF (C .GE. G) GO TO 220                                        BAL00920
         F = F * RADIX                                                  BAL00930
         C = C * B2                                                     BAL00940
         GO TO 210                                                      BAL00950
  220    G = R * RADIX                                                  BAL00960
  230    IF (C .LT. G) GO TO 240                                        BAL00970
         F = F / RADIX                                                  BAL00980
         C = C / B2                                                     BAL00990
         GO TO 230                                                      BAL01000
C     ********** NOW BALANCE **********                                 BAL01010
  240    IF ((C + R) / F .GE. 0.95 * S) GO TO 270                       BAL01020
         G = 1.0D0 / F                                                  BAL01030
         SCALE(I) = SCALE(I) * F                                        BAL01040
         NOCONV = .TRUE.                                                BAL01050
C                                                                       BAL01060
         DO 250 J = K, N                                                BAL01070
  250    A(I,J) = A(I,J) * G                                            BAL01080
C                                                                       BAL01090
         DO 260 J = 1, L                                                BAL01100
  260    A(J,I) = A(J,I) * F                                            BAL01110
C                                                                       BAL01120
  270 CONTINUE                                                          BAL01130
C                                                                       BAL01140
      IF (NOCONV) GO TO 190                                             BAL01150
C                                                                       BAL01160
  280 LOW = K                                                           BAL01170
      IGH = L                                                           BAL01180
      RETURN                                                            BAL01190
C     ********** LAST CARD OF BALANC **********                         BAL01200
      END                                                               BAL01210
      SUBROUTINE ELMHES(NM,N,LOW,IGH,A,INT)                             ELM00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         ELM00020
      INTEGER I,J,M,N,LA,NM,IGH,KP1,LOW,MM1,MP1                         ELM00030
      DIMENSION A(NM,N)                                                 ELM00040
C     REAL X,Y                                                          ELM00050
C     REAL DABS                                                         ELM00060
      INTEGER INT(IGH)                                                  ELM00070
C                                                                       ELM00080
      LA = IGH - 1                                                      ELM00090
      KP1 = LOW + 1                                                     ELM00100
      IF (LA .LT. KP1) GO TO 200                                        ELM00110
C                                                                       ELM00120
      DO 180 M = KP1, LA                                                ELM00130
         MM1 = M - 1                                                    ELM00140
         X = 0.0D0                                                      ELM00150
         I = M                                                          ELM00160
C                                                                       ELM00170
         DO 100 J = M, IGH                                              ELM00180
            IF (DABS(A(J,MM1)) .LE. DABS(X)) GO TO 100                  ELM00190
            X = A(J,MM1)                                                ELM00200
            I = J                                                       ELM00210
  100    CONTINUE                                                       ELM00220
C                                                                       ELM00230
         INT(M) = I                                                     ELM00240
         IF (I .EQ. M) GO TO 130                                        ELM00250
C    ********** INTERCHANGE ROWS AND COLUMNS OF A **********            ELM00260
         DO 110 J = MM1, N                                              ELM00270
            Y = A(I,J)                                                  ELM00280
            A(I,J) = A(M,J)                                             ELM00290
            A(M,J) = Y                                                  ELM00300
  110    CONTINUE                                                       ELM00310
C                                                                       ELM00320
         DO 120 J = 1, IGH                                              ELM00330
            Y = A(J,I)                                                  ELM00340
            A(J,I) = A(J,M)                                             ELM00350
            A(J,M) = Y                                                  ELM00360
  120    CONTINUE                                                       ELM00370
C    ********** END INTERCHANGE **********                              ELM00380
  130    IF (X .EQ. 0.0D0) GO TO 180                                    ELM00390
         MP1 = M + 1                                                    ELM00400
C                                                                       ELM00410
         DO 160 I = MP1, IGH                                            ELM00420
            Y = A(I,MM1)                                                ELM00430
            IF (Y .EQ. 0.0D0) GO TO 160                                 ELM00440
            Y = Y / X                                                   ELM00450
            A(I,MM1) = Y                                                ELM00460
C                                                                       ELM00470
            DO 140 J = M, N                                             ELM00480
  140       A(I,J) = A(I,J) - Y * A(M,J)                                ELM00490
C                                                                       ELM00500
            DO 150 J = 1, IGH                                           ELM00510
  150       A(J,M) = A(J,M) + Y * A(J,I)                                ELM00520
C                                                                       ELM00530
  160    CONTINUE                                                       ELM00540
C                                                                       ELM00550
  180 CONTINUE                                                          ELM00560
C                                                                       ELM00570
  200 RETURN                                                            ELM00580
C    ********** LAST CARD OF ELMHES **********                          ELM00590
      END                                                               ELM00600
      SUBROUTINE ELMBAK(NM,LOW,IGH,A,INT,M,Z)                           ELM00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         ELM00020
      INTEGER I,J,M,LA,MM,MP,NM,IGH,KP1,LOW,MP1                         ELM00030
      DIMENSION A(NM,IGH),Z(NM,M)                                       ELM00040
C     REAL X                                                            ELM00050
      INTEGER INT(IGH)                                                  ELM00060
C                                                                       ELM00070
C                                                                       ELM00080
      IF (M .EQ. 0) GO TO 200                                           ELM00090
      LA = IGH - 1                                                      ELM00100
      KP1 = LOW + 1                                                     ELM00110
      IF (LA .LT. KP1) GO TO 200                                        ELM00120
C     ********** FOR MP=IGH-1 STEP -1 UNTIL LOW+1 DO -- **********      ELM00130
      DO 140 MM = KP1, LA                                               ELM00140
         MP = LOW + IGH - MM                                            ELM00150
         MP1 = MP + 1                                                   ELM00160
C                                                                       ELM00170
         DO 110 I = MP1, IGH                                            ELM00180
            X = A(I,MP-1)                                               ELM00190
            IF (X .EQ. 0.0) GO TO 110                                   ELM00200
C                                                                       ELM00210
            DO 100 J = 1, M                                             ELM00220
  100       Z(I,J) = Z(I,J) + X * Z(MP,J)                               ELM00230
C                                                                       ELM00240
  110    CONTINUE                                                       ELM00250
C                                                                       ELM00260
         I = INT(MP)                                                    ELM00270
         IF (I .EQ. MP) GO TO 140                                       ELM00280
C                                                                       ELM00290
         DO 130 J = 1, M                                                ELM00300
            X = Z(I,J)                                                  ELM00310
            Z(I,J) = Z(MP,J)                                            ELM00320
            Z(MP,J) = X                                                 ELM00330
  130    CONTINUE                                                       ELM00340
C                                                                       ELM00350
  140 CONTINUE                                                          ELM00360
C                                                                       ELM00370
  200 RETURN                                                            ELM00380
C     ********** LAST CARD OF ELMBAK **********                         ELM00390
      END                                                               ELM00400
      FUNCTION DREAL(Z)                                                 DRE00010
      REAL*8 A(2),DREAL                                                 DRE00020
      COMPLEX*16 Z,B                                                    DRE00030
      EQUIVALENCE (A,B)                                                 DRE00040
      B=Z                                                               DRE00050
      DREAL=A(1)                                                        DRE00060
      RETURN                                                            DRE00070
      END                                                               DRE00080
      FUNCTION DIMAG(Z)                                                 DIM00010
      REAL*8 A(2),DIMAG                                                 DIM00020
      COMPLEX*16 Z,B                                                    DIM00030
      EQUIVALENCE (A,B)                                                 DIM00040
      B=Z                                                               DIM00050
      DIMAG=A(2)                                                        DIM00060
      RETURN                                                            DIM00070
      END                                                               DIM00080
      SUBROUTINE BALBAK(NM,N,LOW,IGH,SCALE,M,Z)                         BAL00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         BAL00020
      INTEGER I,J,K,M,N,II,NM,IGH,LOW                                   BAL00030
      DIMENSION SCALE(N),Z(NM,M)                                        BAL00040
C     REAL S                                                            BAL00050
      IF (M .EQ. 0) GO TO 200                                           BAL00060
      IF (IGH .EQ. LOW) GO TO 120                                       BAL00070
C                                                                       BAL00080
      DO 110 I = LOW, IGH                                               BAL00090
         S = SCALE(I)                                                   BAL00100
C     ********** LEFT HAND EIGENVECTORS ARE BACK TRANSFORMED            BAL00110
C                IF THE FOREGOING STATEMENT IS REPLACED BY              BAL00120
C                S=1.0/SCALE(I). **********                             BAL00130
         DO 100 J = 1, M                                                BAL00140
  100    Z(I,J) = Z(I,J) * S                                            BAL00150
C                                                                       BAL00160
  110 CONTINUE                                                          BAL00170
C     ********- FOR I=LOW-1 STEP -1 UNTIL 1,                            BAL00180
C               IGH+1 STEP 1 UNTIL N DO -- **********                   BAL00190
  120 DO 140 II = 1, N                                                  BjL00200
         I = II                                                         BAL00210
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 140                     BAL00220
         IF (I .LT. LOW) I = LOW - II                                   BAL00230
         K = SCALE(I)                                                   BAL00240
         IF (K .EQ. I) GO TO 140                                        BAL00250
C                                                                       BAL00260
         DO 130 J = 1, M                                                BAL00270
            S = Z(I,J)                                                  BAL00280
            Z(I,J) = Z(K,J)                                             BAL00290
            Z(K,J) = S                                                  BAL00300
  130    CONTINUE                                                       BAL00310
C                                                                       BAL00320
  140 CONTINUE                                                          BAL00330
C                                                                       BAL00340
  200 RETURN                                                            BAL00350
C     ********** LAST CARD OF BALBAK **********                         BAL00360
      END                                                               BAL00370
      SUBROUTINE DETFAC(NMAX,N,A,IPIVOT,IDET,DETERM,ISCALE,WK,IERR)     DET00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         DET00020
      DIMENSION A(NMAX,1),IPIVOT(1),WK(1)                               DET00030
C                                                                       DET00040
      DATA R1,R2/1.0D+75,1.0D-75/                                       DET00050
C                                                                       DET00060
      ISCALE=0                                                          DET00070
      NM1=N-1                                                           DET00080
      IERR=0                                                            DET00090
C                                                                       DET00100
C     DETERMINANT CALCULATION TEST                                      DET00110
C                                                                       DET00120
      IF(IDET.EQ.1)GO TO 230                                            DET00130
C                                                                       DET00140
C     TEST FOR A SCALAR MATRIX                                          DET00150
C                                                                       DET00160
      IF(NM1.GT.0)GO TO 20                                              DET00170
      DETERM=A(1,1)                                                     DET00180
      RETURN                                                            DET00190
C                                                                       DET00200
C     COMPUTE SCALING FACTORS                                           DET00210
C                                                                       DET00220
   20 CONTINUE                                                          DET00230
      DO 60 I=1,N                                                       DET00240
      P=0.0                                                             DET00250
      DO 30 J=1,N                                                       DET00260
      Q=DMAX1(P,DABS(A(I,J)))                                           DET00270
      IF(Q.GT.P)P=Q                                                     DET00280
   30 CONTINUE                                                          DET00290
      IF(P)60,40,60                                                     DET00300
   40 DETERM=0.0                                                        DET00310
      IERR=1                                                            DET00320
      RETURN                                                            DET00330
   60 WK(I)=P                                                           DET00340
C                                                                       DET00350
      DO 210 M=1,NM1                                                    DET00360
C                                                                       DET00370
C     PIVOTAL LOGIC SETUP                                               DET00380
C                                                                       DET00390
      P=0.0                                                             DET00400
      DO 110 I=M,N                                                      DET00410
      Q=DABS(A(I,M)/WK(I))                                              DET00420
      IF(Q-P)110,110,100                                                DET00430
  100 P=Q                                                               DET00440
      IP=I                                                              DET00450
  110 CONTINUE                                                          DET00460
C                                                                       DET00470
      IPIVOT(M)=IP                                                      DET00480
C                                                                       DET00490
      IF(P.EQ.0.)GO TO 40                                               DET00500
      IF(M.EQ.IP)GO TO 155                                              DET00510
C                                                                       DET00520
C     PIVOT THE M-TH ROW OF THE A MATRIX                                DET00530
C                                                                       DET00540
      DO 150 I=1,N                                                      DET00550
      P=A(IP,I)                                                         DET00560
      A(IP,I)=A(M,I)                                                    DET00570
  150 A(M,I)=P                                                          DET00580
C                                                                       DET00590
      P=WK(IP)
      WK(IP)=WK(M)                                                      DET00610
      WK(M)=P                                                           DET00620
C                                                                       DET00630
  155 MP1=M+1                                                           DET00640
C                                                                       DET00650
C      L/U FACTORIZATION LOGIC                                          DET00660
C                                                                       DET00670
      P=A(M,M)                                                          DET00680
      DO 180 I=MP1,N                                                    DET00690
      A(I,M)=A(I,M)/P                                                   DET00700
      Q=A(I,M)                                                          DET00710
      DO 180 K=MP1,N                                                    DET00720
  180 A(I,K)=A(I,K)-Q*A(M,K)                                            DET00730
C                                                                       DET00740
  210 CONTINUE                                                          DET00750
C                                                                       DET00760
      IPIVOT(N)=N                                                       DET00770
      IF (A(N,N) .EQ. 0.0) GO TO 40                                     DET00780
C                                                                       DET00790
C     CALCULATION OF THE DETERMINANT OF A                               DET00800
C                                                                       DET00810
      IF(IDET.EQ.0)RETURN                                               DET00820
C                                                                       DET00830
  230 SIGN=1.0                                                          DET00840
      DETERM=1.0                                                        DET00850
C                                                                       DET00860
C     ADJUST SIGN OF DETERMINANT DUE TO PIVOTAL STRATEGY                DET00870
C                                                                       DET00880
      DO 250 I=1,NM1                                                    DET00890
      IF(I-IPIVOT(I))240,250,240                                        DET00900
  240 SIGN=-SIGN                                                        DET00910
  250 CONTINUE                                                          DET00920
C                                                                       DET00930
      DO 340 I=1,N                                                      DET00940
      P=A(I,I)                                                          DET00950
C                                                                       DET00960
  260 CONTINUE                                                          DET00970
      IF(R1.GT.DABS(P))GO TO 280                                        DET00980
      P=P*R2                                                            DET00990
      ISCALE=ISCALE+1                                                   DET01000
      GO TO 260                                                         DET01010
C                                                                       DET01020
  280 CONTINUE                                                          DET01030
      IF(R2.LT.DABS(P))GO TO 290                                        DET01040
      P=P*R1                                                            DET01050
      ISCALE=ISCALE-1                                                   DET01060
      GO TO 280                                                         DET01070
C                                                                       DET01080
  290 DETERM=DETERM*P                                                   DET01090
C                                                                       DET01100
  300 CONTINUE                                                          DET01110
      IF(R1.GT.DABS(DETERM))GO TO 320                                   DET01120
      DETERM=DETERM*R2                                                  DET01130
      ISCALE=ISCALE+1                                                   DET01140
      GO TO 300                                                         DET01150
C                                                                       DET01160
  320 CONTINUE                                                          DET01170
      IF(R2.LT.DABS(DETERM))GO TO 340                                   DET01180
      DETERM=DETERM*R1                                                  DET01190
      ISCALE=ISCALE-1                                                   DET01200
      GO TO 320                                                         DET01210
C                                                                       DET01220
  340 CONTINUE                                                          DET01230
C                                                                       DET01240
      DETERM=DETERM*SIGN                                                DET01250
C                                                                       DET01260
      RETURN                                                            DET01270
      END                                                               DET01280
      SUBROUTINE READ(I,A,NA,B,NB,C,NC,D,ND,E,NE)                       REA00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         REA00020
      DIMENSION A(1),B(1),C(1),D(1),E(1)                                REA00030
      DIMENSION NA(2),NB(2),NC(2),ND(2),NE(2),NZ(2)                     REA00040
      READ(5,100) LAB,            NZ(1), NZ(2)                          REA00050
      CALL READ1(A, NA,NZ,  LAB)                                        REA00060
      IF(I .EQ. 1) GO TO 999                                            REA00070
      READ(5,100) LAB,            NZ(1), NZ(2)                          REA00080
      CALL READ1(B, NB,NZ,  LAB)                                        REA00090
      IF(I .EQ. 2) GO TO 999                                            REA00100
      READ(5,100) LAB,            NZ(1), NZ(2)                          REA00110
      CALL READ1(C,NC,NZ,LAB)                                           REA00120
      IF(I .EQ. 3) GO TO 999                                            REA00130
      READ(5,100) LAB,            NZ(1), NZ(2)                          REA00140
      CALL READ1(D, ND,NZ,  LAB)                                        REA00150
      IF(I .EQ. 4) GO TO 999                                            REA00160
      READ(5,100) LAB,            NZ(1), NZ(2)                          REA00170
      CALL READ1(E, NE,NZ,  LAB)                                        REA00180
  100 FORMAT(A4,4X,2I4)                                                 REA00190
  999 RETURN                                                            REA00200
      END                                                               REA00210
      SUBROUTINE JUXTC(A,NA,B,NB,C,NC)                                  JUX00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         JUX00020
      DIMENSION A(1),B(1),C(1),NA(2),NB(2),NC(2)                        JUX00030
      IF (NA(1).NE.NB(1)) GO TO 600                                     JUX00040
      NC(1)=NA(1)                                                       JUX00050
      NC(2)=NA(2)+NB(2)                                                 JUX00060
      L=NA(1)*NA(2)                                                     JUX00070
      NNC=NC(1)*NC(2)                                                   JUX00080
      IF( NA(1) .LT. 1 .OR. L .LT. 1 ) GO TO 600                        JUX00090
      IF( NC(2) .LT. 1  )  GO TO 600                                    JUX00100
      MS=NA(1)*NA(2)                                                    JUX00110
      DO 10 I=1,MS                                                      JUX00120
   10 C(I)=A(I)                                                         JUX00130
      MBS=NA(1)*NB(2)                                                   JUX00140
      DO 20 I=1,MBS                                                     JUX00150
      J=MS+I                                                            JUX00160
   20 C(J)=B(I)                                                         JUX00170
      RETURN                                                            JUX00180
  600 CALL LNCNT(1)                                                     JUX00190
      WRITE (6,1600) NA,NB                                              JUX00200
 1600 FORMAT (' DIMENSION ERROR IN JUXTC,  NA=',2I6,5X,'NB=',2I6)       JUX00210
      RETURN                                                            JUX00220
      END                                                               JUX00230
      SUBROUTINE ASMREG(A,NA,B,NB,H,NH,Q,NQ,R,NR,F,NF,P,NP,IDENT,DISC,N ASM00010
     1EWT,STABLE,FNULL,ALPHA,IOP,DUMMY)                                 ASM00020
      IMPLICIT REAL*8 (A-H,O-Z)                                         ASM00030
      DIMENSION A(1),B(1),H(1),Q(1),R(1),F(1),P(1),DUMMY(1)             ASM00040
      DIMENSION NA(2),NB(2),NH(2),NQ(2),NR(2),NF(2),NP(2),IOP(5),IOPT(3)ASM00050
     1,NDUM1(2),NDUM2(2),NDUM3(2)                                       ASM00060
      LOGICAL IDENT,DISC,NEWT,STABLE,FNULL,SING                         ASM00070
      N = NA(1)**2                                                      ASM00080
      N1= N+1                                                           ASM00090
      IOPTT=0                                                           ASM00100
      IF ( .NOT. NEWT ) GO TO 600                                       ASM00110
      IF( STABLE )  GO TO 500                                           ASM00120
      IF ( FNULL ) GO TO 100                                            ASM00130
      CALL MULT(B,NB,F,NF,DUMMY,NA)                                     ASM00140
      CALL SUBT(A,NA,DUMMY,NA,DUMMY,NA)                                 ASM00150
      CALL TESTSA(DUMMY,NA,ALPHA,DISC,STABLE,IOPTT,DUMMY(N1))           ASM00160
      GO TO 200                                                         ASM00170
  100 CONTINUE                                                          ASM00180
      CALL TESTSA(A,NA,ALPHA,DISC,STABLE,IOPTT,DUMMY)                   ASM00190
C                                                                       ASM00200
  200 CONTINUE                                                          ASM00210
      IF( STABLE ) GO TO 500                                            ASM00220
      IF( DISC ) GO TO 230                                              ASM00230
      J = -NA(1)                                                        ASM00240
      NAX = NA(1)                                                       ASM00250
      DO 210 I =1,NAX                                                   ASM00260
      J = J + NAX +1                                                    ASM00270
      A(J) = A(J)-ALPHA                                                 ASM00280
  210 CONTINUE                                                          ASM00290
      SCLE = 3.                                                         ASM00300
      IOPT(1)=IOP(1)                                                    ASM00310
      IOPT(2) = 1                                                       ASM00320
      IOPT(3)=1                                                         ASM00330
      CALL CSTAB(A,NA,B,NB,F,NF,IOPT,SCLE,DUMMY)                        ASM00340
      J = -NA(1)                                                        ASM00350
      DO 220 I=1,NAX                                                    ASM00360
      J = J + NAX + 1                                                   ASM00370
      A(J) = A(J) + ALPHA                                               ASM00380
  220 CONTINUE                                                          ASM00390
  225 CONTINUE                                                          ASM00400
      CALL MULT(B,NB,F,NF,DUMMY,NA)                                     ASM00410
      CALL SUBT(A,NA,DUMMY,NA,DUMMY,NA)                                 ASM00420
      CALL TESTSA(DUMMY,NA,ALPHA,DISC,STABLE,IOPTT,DUMMY(N1))           ASM00430
      GO TO 300                                                         ASM00440
C                                                                       ASM00450
  230 CONTINUE                                                          ASM00460
      J = 2*NA(1) + 1                                                   ASM00470
      IF( .NOT. FNULL )  J = J + N                                      ASM00480
      SING = .FALSE.                                                    ASM00490
      IF( DUMMY(J) .EQ. 0.0 )  SING = .TRUE.                            ASM00500
      IOPT(1) = IOP(1)                                                  ASM00510
      IOPT(2) = 1                                                       ASM00520
      DSCLE = 0.5                                                       ASM00530
      ALPHAT = 1./ALPHA                                                 ASM00540
      CALL SCALE(A,NA,A,NA,ALPHAT)                                      ASM00550
      CALL SCALE(B,NB,B,NB,ALPHAT)                                      ASM00560
      CALL DSTAB(A,NA,B,NB,F,NF,SING,IOPT,DSCLE,DUMMY)                  ASM00570
      CALL SCALE(A,NA,A,NA,ALPHA)                                       ASM00580
      CALL SCALE(B,NB,B,NB,ALPHA)                                       ASM00590
      GO TO 225                                                         ASM00600
C                                                                       ASM00610
  300 CONTINUE                                                          ASM00620
      IF( STABLE) GO TO 400                                             ASM00630
      CALL LNCNT(5)                                                     ASM00640
      IF( DISC ) GO TO 330                                              ASM00650
      PRINT 310,ALPHA                                                   ASM00660
  310 FORMAT(//' IN ASMREG, CSTAB HAS FAILED TO FIND A STABILIZING GAIN ASM00670
     1 MATRIX (F) RELATIVE TO ',/,' ALPHA = ',D16.8/)                   ASM00680
      RETURN                                                            ASM00690
  330 CONTINUE                                                          ASM00700
      PRINT 340,ALPHA                                                   ASM00710
  340 FORMAT(//' IN ASMREG, DSTAB HAS FAILED TO FIND A STABILIZING GAIN ASM00720
     1 MATRIX (F) RELATIVE TO ',/,' ALPHA = ',D16.8/)                   ASM00730
      RETURN                                                            ASM00740
C                                                                       ASM00750
  400 CONTINUE                                                          ASM00760
      FNULL = .FALSE.                                                   ASM00770
C                                                                       ASM00780
  500 CONTINUE                                                          ASM00790
      CALL RICNWT(A,NA,B,NB,H,NH,Q,NQ,R,NR,F,NF,P,NP,IOP,IDENT,DISC,FNU ASM00800
     1LL,DUMMY)                                                         ASM00810
      GO TO 750                                                         ASM00820
C                                                                       ASM00830
  600 CONTINUE                                                          ASM00840
      IF( DISC ) GO TO 700                                              ASM00850
      NW = 4*N + 1                                                      ASM00860
      NLAM = NW + 4*N                                                   ASM00870
      NDUM = NLAM + N                                                   ASM00880
      IOP(3) = 1                                                        ASM00890
      CALL CNTREG(A,NA,B,NB,H,NH,Q,NQ,R,NR,DUMMY,DUMMY(NW),DUMMY(NLAM), ASM00900
     1S,F,NF,P,NP,T,IOP,IDENT,DUMMY(NDUM))                              ASM00910
      GO TO 750                                                         ASM00920
  700 CONTINUE                                                          ASM00930
      CALL DISREG(A,NA,B,NB,H,NH,Q,NQ,R,NR,F,NF,P,NP,IOP,IDENT,DUMMY)   ASM00940
C                                                                       ASM00950
  750 CONTINUE                                                          ASM00960
C                                                                       ASM00970
      IF( IOP(4) .EQ. 0 ) GO TO 1100                                    ASM00980
C                                                                       ASM00990
      N2= N1 + N                                                        ASM01000
      N3= N2 + N                                                        ASM01010
C                                                                       ASM01020
      IF( DISC ) GO TO 800                                              ASM01030
      CALL MULT(P,NP,B,NB,DUMMY,NB)                                     ASM01040
      CALL MULT(DUMMY,NB,F,NF,DUMMY(N1),NP)                             ASM01050
      CALL TRANP(DUMMY(N1),NP,DUMMY,NP)                                 ASM01060
      CALL ADD(DUMMY,NP,DUMMY(N1),NP,DUMMY,NP)                          ASM01070
      CALL SCALE(DUMMY,NP,DUMMY,NP,0.5)                                 ASM01080
      CALL SUBT(Q,NQ,DUMMY,NP,DUMMY,NP)                                 ASM01090
      CALL MULT(P,NP,A,NA,DUMMY(N1),NP)                                 ASM01100
      CALL ADD(DUMMY,NP,DUMMY(N1),NP,DUMMY,NP)                          ASM01110
      CALL TRANP(DUMMY(N1),NP,DUMMY(N2),NP)                             ASM01120
      CALL ADD(DUMMY,NP,DUMMY(N2),NP,DUMMY,NP)                          ASM01130
      GO TO 900                                                         ASM01140
C                                                                       ASM01150
  800 CONTINUE                                                          ASM01160
      CALL MULT(R,NR,F,NF,DUMMY,NF)                                     ASM01170
      CALL TRANP(F,NF,DUMMY(N1),NB)                                     ASM01180
      CALL MULT(DUMMY(N1),NB,DUMMY,NF,DUMMY(N2),NA)                     ASM01190
      CALL ADD(DUMMY(N2),NA,Q,NQ,DUMMY,NA)                              ASM01200
      CALL MULT(B,NB,F,NF,DUMMY(N1),NA)                                 ASM01210
      CALL SUBT(A,NA,DUMMY(N1),NA,DUMMY(N1),NA)                         ASM01220
      CALL MULT(P,NP,DUMMY(N1),NA,DUMMY(N2),NA)                         ASM01230
      CALL TRANP(DUMMY(N1),NA,DUMMY(N3),NA)                             ASM01240
      CALL MULT(DUMMY(N3),NA,DUMMY(N2),NA,DUMMY(N1),NA)                 ASM01250
      CALL ADD(DUMMY,NA,DUMMY(N1),NA,DUMMY,NA)                          ASM01260
      CALL SUBT(P,NP,DUMMY,NA,DUMMY,NA)                                 ASM01270
C                                                                       ASM01280
  900 CONTINUE                                                          ASM01290
      CALL LNCNT(4)                                                     ASM01300
      PRINT 1000                                                        ASM01310
 1000 FORMAT(//' RESIDUAL ERROR IN RICCATI EQUATION '/)                 ASM01320
      CALL PRNT(DUMMY,NP,4HEROR,1)                                      ASM01330
C                                                                       ASM01340
 1100 CONTINUE                                                          ASM01350
      N2= N1+NA(1)                                                      ASM01360
      N3= N2+NA(1)                                                      ASM01370
      ISV = 0                                                           ASM01380
      CALL EQUATE(P,NP,DUMMY,NP)                                        ASM01390
      CALL EIGEN(NA(1),NA(1),DUMMY,DUMMY(N1),DUMMY(N2),ISV,ISV,V,DUMMY(NASM01400
     13),IERR)                                                          ASM01410
      NEVL = NA(1)                                                      ASM01420
      IF( IERR .EQ. 0) GO TO 1300                                       ASM01430
      NEVL=NA(1)-IERR                                                   ASM01440
      CALL LNCNT(4)                                                     ASM01450
      PRINT 1200,IERR                                                   ASM01460
 1200 FORMAT(//' IN ASMREG, THE ',I5, ' EIGENVALUE OF P  HAS NOT BEEN COASM01470
     1PUTED AFTER 30 ITERATIONS '/)                                     ASM01480
C                                                                       ASM01490
 1300 CONTINUE                                                          ASM01500
      NDUM1(1) = NEVL                                                   ASM01510
      NDUM1(2) = 1                                                      ASM01520
      CALL EQUATE(DUMMY(N1),NDUM1,DUMMY,NDUM1)                          ASM01530
      N1 = NDUM1(1) +1                                                  ASM01540
      CALL MULT(B,NB,F,NF,DUMMY(N1),NA)                                 ASM01550
      CALL SUBT(A,NA,DUMMY(N1),NA,DUMMY(N1),NA)                         ASM01560
      N2 = N1+N                                                         ASM01570
      CALL EQUATE(DUMMY(N1),NA,DUMMY(N2),NA)                            ASM01580
      N3=N2+N                                                           ASM01590
      N4=N3+NA(1)                                                       ASM01600
      N5=N4+NA(1)                                                       ASM01610
      CALL EIGEN(NA(1),NA(1),DUMMY(N2),DUMMY(N3),DUMMY(N4),ISV,ISV,V,DUMASM01620
     1MY(N5),IERR)                                                      ASM01630
      NEVL = NA(1)                                                      ASM01640
      IF( IERR .EQ. 0 ) GO TO 1500                                      ASM01650
      NEVL=NA(1)-IERR                                                   ASM01660
      CALL LNCNT(4)                                                     ASM01670
      PRINT 1400,IERR                                                   ASM01680
 1400 FORMAT(//' IN ASMREG, THE ',I5,' EIGENVALUE OF A-BF HAS NOT BEEN CASM01690
     1OMPUTED AFTER 30 ITERATIONS'/)                                    ASM01700
C                                                                       ASM01710
 1500 CONTINUE                                                          ASM01720
      NDUM2(1) = NEVL                                                   ASM01730
      NDUM2(2) = 1                                                      ASM01740
      CALL JUXTC(DUMMY(N3),NDUM2,DUMMY(N4),NDUM2,DUMMY(N2),NDUM3)       ASM01750
C                                                                       ASM01760
      IF ( IOP(5) .EQ. 0 ) RETURN                                       ASM01770
C                                                                       ASM01780
      CALL LNCNT(4)                                                     ASM01790
      PRINT 1600                                                        ASM01800
 1600 FORMAT(//' EIGENVALUES OF P '/)                                   ASM01810
      CALL PRNT(DUMMY,NDUM1,4HEVLP,1)                                   ASM01820
      CALL LNCNT(4)                                                     ASM01830
      PRINT 1700                                                        ASM01840
 1700 FORMAT(//' CLOSED-LOOP RESPONSE MATRIX A-BF '/)                   ASM01850
      CALL PRNT(DUMMY(N1),NA,4HA-BF,1)                                  ASM01860
      CALL LNCNT(3)                                                     ASM01870
      PRINT 1800                                                        ASM01880
 1800 FORMAT(//' EIGENVALUES OF A-BF')                                  ASM01890
      CALL PRNT(DUMMY(N2),NDUM3,0,3)                                    ASM01900
C                                                                       ASM01910
      RETURN                                                            ASM01920
      END                                                               ASM01930
      SUBROUTINE READ1 (A,NA,NZ,NAM)                                    REA00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         REA00020
      DIMENSION A(1),NA(2),NZ(2)                                        REA00030
      IF  (NZ(1).EQ.0)  GO TO 410                                       REA00040
      NR=NZ(1)                                                          REA00050
      NC=NZ(2)                                                          REA00060
      NLST=NR*NC                                                        REA00070
      IF( NLST .LT. 1 .OR. NR .LT. 1 ) GO TO 16                         REA00080
      DO 400 I = 1, NR                                                  REA00090
  400 READ (5,101) (A(  J), J = I,NLST,NR)                              REA00100
      NA(1)=NR                                                          REA00110
      NA(2)=NC                                                          REA00120
  410 CALL  PRNT (A,NA,NAM,1)                                           REA00130
  101 FORMAT(8D10.2)                                                    REA00140
      RETURN                                                            REA00150
   16 CALL LNCNT(1)                                                     REA00160
      WRITE  (6,916)  NAM,NR,NC                                         REA00170
  916 FORMAT  (' ERROR IN READ1   MATRIX ',A4,' HAS NA=',2I6)           REA00180
      RETURN                                                            REA00190
      END                                                               REA00200
      SUBROUTINE AXPXB(A,U,M,NA,NU,B,V,N,NB,NV,C,NC,EPSA,               AXP00010
     1EPSB,FAIL)                                                        AXP00020
      IMPLICIT REAL*8 (A-H,O-Z)                                         AXP00030
      DIMENSION                                                         AXP00040
     1A(NA,1),U(NU,1),B(NB,1),V(NV,1),C(NC,1)                           AXP00050
      INTEGER                                                           AXP00060
C                                                                       AXP00070
     1 FAIL                                                             AXP00080
      M1 = M+1                                                          AXP00090
      MM1 = M-1                                                         AXP00100
      N1 = N+1                                                          AXP00110
      NM1 = N-1                                                         AXP00120
C IF REQUIRED, REDUCE A TO UPPER REAL SCHUR FORM.                       AXP00130
C                                                                       AXP00140
      IF(EPSA .LT. 0.) GO TO 35                                         AXP00150
      DO 10 I=1,M                                                       AXP00160
        DO 10 J=I,M                                                     AXP00170
          TEMP = A(I,J)                                                 AXP00180
          A(I,J) = A(J,I)                                               AXP00190
          A(J,I) = TEMP                                                 AXP00200
   10 CONTINUE                                                          AXP00210
      CALL HSHLDR(A,M,NA)                                               AXP00220
      CALL BCKMLT(A,U,M,NA,NU)                                          AXP00230
      IF(MM1 .EQ. 0) GO TO 25                                           AXP00240
      DO 20 I=1,MM1                                                     AXP00250
        A(I+1,I) = A(I,M1)                                              AXP00260
   20 CONTINUE                                                          AXP00270
      CALL SCHUR(A,U,M,NA,NU,EPSA,FAIL)                                 AXP00280
      IF(FAIL .NE. 0) RETURN                                            AXP00290
   25 DO 30 I=1,M                                                       AXP00300
        DO 30 J=I,M                                                     AXP00310
          TEMP = A(I,J)                                                 AXP00320
          A(I,J) = A(J,I)                                               AXP00330
          A(J,I) = TEMP                                                 AXP00340
   30 CONTINUE                                                          AXP00350
C                                                                       AXP00360
C IF REQUIRED, REDUCE B TO UPPER REAL SCHUR FORM.                       AXP00370
C                                                                       AXP00380
   35 IF(EPSB .LT. 0.) GO TO 45                                         AXP00390
      CALL HSHLDR(B,N,NB)                                               AXP00400
      CALL BCKMLT(B,V,N,NB,NV)                                          AXP00410
      IF(NM1 .EQ. 0) GO TO 45                                           AXP00420
      DO 40 I=1,NM1                                                     AXP00430
        B(I+1,I) = B(I,N1)                                              AXP00440
   40 CONTINUE                                                          AXP00450
      CALL SCHUR(B,V,N,NB,NV,EPSB,FAIL)                                 AXP00460
      FAIL = -FAIL                                                      AXP00470
      IF(FAIL .NE. 0) RETURN                                            AXP00480
C                                                                       AXP00490
C TRANSFORM C.                                                          AXP00500
C                                                                       AXP00510
   45 DO 60 J=1,N                                                       AXP00520
        DO 50 I=1,M                                                     AXP00530
          A(I,M1) = 0.                                                  AXP00540
          DO 50 K=1,M                                                   AXP00550
            A(I,M1) = A(I,M1) + U(K,I)*C(K,J)                           AXP00560
   50 CONTINUE                                                          AXP00570
      DO 60 I=1,M                                                       AXP00580
        C(I,J) = A(I,M1)                                                AXP00590
   60 CONTINUE                                                          AXP00600
      DO 80 I=1,M                                                       AXP00610
        DO 70 J=1,N                                                     AXP00620
          B(N1,J) = 0.                                                  AXP00630
          DO 70 K=1,N                                                   AXP00640
            B(N1,J) = B(N1,J) + C(I,K)*V(K,J)                           AXP00650
   70 CONTINUE                                                          AXP00660
      DO 80 J=1,N                                                       AXP00670
        C(I,J) = B(N1,J)                                                AXP00680
   80 CONTINUE                                                          AXP00690
C                                                                       AXP00700
C SOLVE THE TRANSFORMED SYSTEM.                                         AXP00710
C                                                                       AXP00720
      CALL SHRSLV(A,B,C,M,N,NA,NB,NC)                                   AXP00730
C                                                                       AXP00740
C TRANSFORM C BACK TO THE SOLUTION.                                     AXP00750
C                                                                       AXP00760
      DO 100 J=1,N                                                      AXP00770
        DO 90 I=1,M                                                     AXP00780
          A(I,M1) = 0.                                                  AXP00790
          DO 90 K=1,M                                                   AXP00800
            A(I,M1) = A(I,M1) + U(I,K)*C(K,J)                           AXP00810
   90 CONTINUE                                                          AXP00820
      DO 100 I=1,M                                                      AXP00830
        C(I,J) = A(I,M1)                                                AXP00840
  100 CONTINUE                                                          AXP00850
      DO 120 I=1,M                                                      AXP00860
        DO 110 J=1,N                                                    AXP00870
          B(N1,J) = 0.                                                  AXP00880
          DO 110 K=1,N                                                  AXP00890
            B(N1,J) = B(N1,J) + C(I,K)*V(J,K)                           AXP00900
  110    CONTINUE                                                       AXP00910
         DO 120 J=1,N                                                   AXP00920
           C(I,J) = B(N1,J)                                             AXP00930
  120  CONTINUE                                                         AXP00940
       RETURN                                                           AXP00950
       END                                                              AXP00960
       SUBROUTINE SHRSLV(A,B,C,M,N,NA,NB,NC)                            SHR00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         SHR00020
      DIMENSION                                                         SHR00030
     1A(NA,1),B(NB,1),C(NC,1)                                           SHR00040
      INTEGER                                                           SHR00050
     1 DK,DL                                                            SHR00060
      COMMON/SLVBLK/T(5,5),P(5),NSYS                                    SHR00070
      L = 1                                                             SHR00080
   10   LM1 = L-1                                                       SHR00090
        DL = 1                                                          SHR00100
        IF(L .EQ. N) GO TO 15                                           SHR00110
        IF(B(L+1,L) .NE. 0.) DL = 2                                     SHR00120
   15   LL = L+DL-1                                                     SHR00130
        IF(L .EQ. 1) GO TO 30                                           SHR00140
        DO 20 J=L,LL                                                    SHR00150
          DO 20 I=1,M                                                   SHR00160
            DO 20 IB=1,LM1                                              SHR00170
              C(I,J) = C(I,J) - C(I,IB)*B(IB,J)                         SHR00180
   20   CONTINUE                                                        SHR00190
   30   K = 1                                                           SHR00200
   40     KM1 = K-1                                                     SHR00210
          DK = 1                                                        SHR00220
          IF(K .EQ. M) GO TO 45                                         SHR00230
          IF(A(K,K+1) .NE. 0.) DK = 2                                   SHR00240
   45     KK = K+DK-1                                                   SHR00250
          IF(K .EQ. 1) GO TO 60                                         SHR00260
          DO 50 I=K,KK                                                  SHR00270
            DO 50 J=L,LL                                                SHR00280
              DO 50 JA=1,KM1                                            SHR00290
                C(I,J) = C(I,J) - A(I,JA)*C(JA,J)                       SHR00300
  50      CONTINUE                                                      SHR00310
  60      IF(DL .EQ. 2) GO TO 80                                        SHR00320
          IF(DK .EQ. 2) GO TO 70                                        SHR00330
          T(1,1) = A(K,K) + B(L,L)                                      SHR00340
          IF(T(1,1) .EQ. 0.) STOP                                       SHR00350
          C(K,L) = C(K,L)/T(1,1)                                        SHR00360
          GO TO 100                                                     SHR00370
  70      T(1,1) = A(K,K) + B(L,L)                                      SHR00380
          T(1,2) = A(K,KK)                                              SHR00390
          T(2,1) = A(KK,K)                                              SHR00400
          T(2,2) = A(KK,KK) + B(L,L)                                    SHR00410
          P(1) = C(K,L)                                                 SHR00420
          P(2) = C(KK,L)                                                SHR00430
          NSYS = 2                                                      SHR00440
          CALL SYSSLV                                                   SHR00450
          C(K,L) = P(1)                                                 SHR00460
          C(KK,L) = P(2)                                                SHR00470
          GO TO 100                                                     SHR00480
  80      IF(DK .EQ. 2) GO TO 90                                        SHR00490
          T(1,1) = A(K,K) + B(L,L)                                      SHR00500
          T(1,2) = B(LL,L)                                              SHR00510
          T(2,1) = B(L,LL)                                              SHR00520
          T(2,2) = A(K,K) + B(LL,LL)                                    SHR00530
          P(1) = C(K,L)                                                 SHR00540
          P(2) = C(K,LL)                                                SHR00550
          NSYS = 2                                                      SHR00560
          CALL SYSSLV                                                   SHR00570
          C(K,L) = P(1)                                                 SHR00580
          C(K,LL) = P(2)                                                SHR00590
          GO TO 100                                                     SHR00600
  90      T(1,1) = A(K,K) + B(L,L)                                      SHR00610
          T(1,2) = A(K,KK)                                              SHR00620
          T(1,3) = B(LL,L)                                              SHR00630
          T(1,4) = 0.                                                   SHR00640
          T(2,1) = A(KK,K)                                              SHR00650
          T(2,2) = A(KK,KK) + B(L,L)                                    SHR00660
          T(2,3) = 0.                                                   SHR00670
          T(2,4) = T(1,3)                                               SHR00680
          T(3,1) = B(L,LL)                                              SHR00690
          T(3,2) = 0.                                                   SHR00700
          T(3,3) = A(K,K) + B(LL,LL)                                    SHR00710
          T(3,4) = T(1,2)                                               SHR00720
          T(4,1) = 0.                                                   SHR00730
          T(4,2) = T(3,1)                                               SHR00740
          T(4,3) = T(2,1)                                               SHR00750
          T(4,4) = A(KK,KK) + B(LL,LL)                                  SHR00760
          P(1) = C(K,L)                                                 SHR00770
          P(2) = C(KK,L)                                                SHR00780
          P(3) = C(K,LL)                                                SHR00790
          P(4) = C(KK,LL)                                               SHR00800
          NSYS = 4                                                      SHR00810
          CALL SYSSLV                                                   SHR00820
          C(K,L) = P(1)                                                 SHR00830
          C(KK,L) = P(2)                                                SHR00840
          C(K,LL) = P(3)                                                SHR00850
          C(KK,LL) = P(4)                                               SHR00860
  100   K = K + DK                                                      SHR00870
        IF(K .LE. M) GO TO 40                                           SHR00880
      L = L + DL                                                        SHR00890
      IF(L .LE. N) GO TO 10                                             SHR00900
      RETURN                                                            SHR00910
      END                                                               SHR00920
      SUBROUTINE ATXPXA(A,U,C,N,NA,NU,NC,EPS,FAIL)                      ATX00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         ATX00020
      DIMENSION                                                         ATX00030
     1A(NA,1),U(NU,1),C(NC,1)                                           ATX00040
      INTEGER                                                           ATX00050
     1 FAIL                                                             ATX00060
      N1 = N+1                                                          ATX00070
      NM1 = N-1                                                         ATX00080
C                                                                       ATX00090
C IF REQUIRED, REDUCE A TO LOWER REAL SCHUR FORM.                       ATX00100
C                                                                       ATX00110
      IF(EPS .LT. 0.) GO TO 15                                          ATX00120
      CALL HSHLDR(A,N,NA)                                               ATX00130
      CALL BCKMLT(A,U,N,NA,NU)                                          ATX00140
      DO 10 I=1,NM1                                                     ATX00150
        A(I+1,I) = A(I,N1)                                              ATX00160
   10 CONTINUE                                                          ATX00170
      CALL SCHUR(A,U,N,NA,NU,EPS,FAIL)                                  ATX00180
      IF(FAIL .NE. 0) RETURN                                            ATX00190
C                                                                       ATX00200
C TRANSFORM C.                                                          ATX00210
C                                                                       ATX00220
   15 DO 20 I=1,N                                                       ATX00230
          C(I,I)=C(I,I)/2.                                              ATX00240
   20 CONTINUE                                                          ATX00250
      DO 40 I=1,N                                                       ATX00260
        DO 30 J=1,N                                                     ATX00270
          A(N1,J) = 0.                                                  ATX00280
          DO 30 K=I,N                                                   ATX00290
            A(N1,J) = A(N1,J) + C(I,K)*U(K,J)                           ATX00300
   30   CONTINUE                                                        ATX00310
          DO 40 J=1,N                                                   ATX00320
          C(I,J) = A(N1,J)                                              ATX00330
   40 CONTINUE                                                          ATX00340
      DO 60 J=1,N                                                       ATX00350
        DO 50 I=1,N                                                     ATX00360
          A(I,N1) = 0.                                                  ATX00370
          DO 50 K=1,N                                                   ATX00380
            A(I,N1) = A(I,N1) + U(K,I)*C(K,J)                           ATX00390
   50   CONTINUE                                                        ATX00400
        DO 60 I=1,N                                                     ATX00410
          C(I,J) = A(I,N1)                                              ATX00420
   60 CONTINUE                                                          ATX00430
      DO 70 I=1,N                                                       ATX00440
        DO 70 J=I,N                                                     ATX00450
          C(I,J) = C(I,J) + C(J,I)                                      ATX00460
          C(J,I) = C(I,J)                                               ATX00470
   70 CONTINUE                                                          ATX00480
C                                                                       ATX00490
C SOLVE THE TRANSFORMED SYSTEM.                                         ATX00500
C                                                                       ATX00510
      CALL SYMSLV(A,C,N,NA,NC)                                          ATX00520
C                                                                       ATX00530
C TRANSFORM C BACK TO THE SOLUTION.                                     ATX00540
C                                                                       ATX00550
      DO 80 I=1,N                                                       ATX00560
        C(I,I) = C(I,I)/2.                                              ATX00570
   80 CONTINUE                                                          ATX00580
      DO 100 I=1,N                                                      ATX00590
        DO 90 J=1,N                                                     ATX00600
          A(N1,J) = 0.                                                  ATX00610
          DO 90 K=I,N                                                   ATX00620
            A(N1,J) = A(N1,J) + C(I,K)*U(J,K)                           ATX00630
   90   CONTINUE                                                        ATX00640
        DO 100 J=1,N                                                    ATX00650
          C(I,J) = A(N1,J)                                              ATX00660
  100 CONTINUE                                                          ATX00670
      DO 120 J=1,N                                                      ATX00680
        DO 110 I=1,N                                                    ATX00690
          A(I,N1) = 0.                                                  ATX00700
          DO 110 K=1,N                                                  ATX00710
            A(I,N1) = A(I,N1) + U(I,K)*C(K,J)                           ATX00720
  110   CONTINUE                                                        ATX00730
        DO 120 I=1,N                                                    ATX00740
          C(I,J) = A(I,N1)                                              ATX00750
  120 CONTINUE                                                          ATX00760
      DO 130 I=1,N                                                      ATX00770
        DO 130 J=I,N                                                    ATX00780
          C(I,J) = C(I,J) + C(J,I)                                      ATX00790
          C(J,I) = C(I,J)                                               ATX00800
  130 CONTINUE                                                          ATX00810
      RETURN                                                            ATX00820
      END                                                               ATX00830
      SUBROUTINE SYMSLV(A,C,N,NA,NC)                                    SYM00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         SYM00020
      DIMENSION                                                         SYM00030
     1A(NA,1),C(NC,1)                                                   SYM00040
      INTEGER                                                           SYM00050
     1 DK,DL                                                            SYM00060
      COMMON/SLVBLK/T(5,5),P(5),NSYS                                    SYM00070
      L = 1                                                             SYM00080
   10   DL = 1                                                          SYM00090
        IF(L .EQ. N) GO TO 20                                           SYM00100
        IF(A(L+1,L) .NE. 0.) DL = 2                                     SYM00110
   20   LL = L+DL-1                                                     SYM00120
        K = L                                                           SYM00130
   30     KM1 = K-1                                                     SYM00140
          DK = 1                                                        SYM00150
          IF(K .EQ. N) GO TO 35                                         SYM00160
          IF(A(K+1,K) .NE. 0.) DK = 2                                   SYM00170
   35     KK = K+DK-1                                                   SYM00180
          IF(K .EQ. L) GO TO 45                                         SYM00190
          DO 40 I=K,KK                                                  SYM00200
            DO 40 J=L,LL                                                SYM00210
              DO 40 IA=L,KM1                                            SYM00220
                C(I,J) = C(I,J) - A(IA,I)*C(IA,J)                       SYM00230
   40     CONTINUE                                                      SYM00240
   45     IF(DL .EQ. 2) GO TO 60                                        SYM00250
          IF(DK .EQ. 2 ) GO TO 50                                       SYM00260
          T(1,1) = A(K,K) + A(L,L)                                      SYM00270
          IF(T(1,1) .EQ. 0.) STOP                                       SYM00280
          C(K,L) = C(K,L)/T(1,1)                                        SYM00290
          GO TO 90                                                      SYM00300
  50      T(1,1) = A(K,K) + A(L,L)                                      SYM00310
          T(1,2) = A(KK,K)                                              SYM00320
          T(2,1) = A(K,KK)                                              SYM00330
          T(2,2) = A(KK,KK) + A(L,L)                                    SYM00340
          P(1) = C(K,L)                                                 SYM00350
          P(2) = C(KK,L)                                                SYM00360
          NSYS = 2                                                      SYM00370
          CALL SYSSLV                                                   SYM00380
          C(K,L) = P(1)                                                 SYM00390
        C(KK,L) = P(2)                                                  SYM00400
          GO TO 90                                                      SYM00410
  60      IF(DK .EQ. 2) GO TO 70                                        SYM00420
          T(1,1) = A(K,K) + A(L,L)                                      SYM00430
          T(1,2) = A(LL,L)                                              SYM00440
          T(2,1) = A(L,LL)                                              SYM00450
          T(2,2) = A(K,K) + A(LL,LL)                                    SYM00460
          P(1) = C(K,L)                                                 SYM00470
          P(2) = C(K,LL)                                                SYM00480
          NSYS = 2                                                      SYM00490
          CALL SYSSLV                                                   SYM00500
          C(K,L) = P(1)                                                 SYM00510
          C(K,LL) = P(2)                                                SYM00520
          GO TO 90                                                      SYM00530
  70      IF(K .NE. L) GO TO 80                                         SYM00540
          T(1,1) = A(L,L)                                               SYM00550
          T(1,2) = A(LL,L)                                              SYM00560
          T(1,3) = 0.                                                   SYM00570
          T(2,1) = A(L,LL)                                              SYM00580
          T(2,2) = A(L,L) + A(LL,LL)                                    SYM00590
          T(2,3) = T(1,2)                                               SYM00600
          T(3,1) = 0.                                                   SYM00610
          T(3,2) = T(2,1)                                               SYM00620
          T(3,3) = A(LL,LL)                                             SYM00630
          P(1) = C(L,L)/2.                                              SYM00640
          P(2) = C(LL,L)                                                SYM00650
          P(3) = C(LL,LL)/2.                                            SYM00660
          NSYS = 3                                                      SYM00670
          CALL SYSSLV                                                   SYM00680
          C(L,L) = P(1)                                                 SYM00690
          C(LL,L) = P(2)                                                SYM00700
          C(L,LL) = P(2)                                                SYM00710
          C(LL,LL) = P(3)                                               SYM00720
          GO TO 90                                                      SYM00730
  80      T(1,1) = A(K,K) + A(L,L)                                      SYM00740
          T(1,2) = A(KK,K)                                              SYM00750
          T(1,3) = A(LL,L)                                              SYM00760
          T(1,4) = 0.                                                   SYM00770
          T(2,1) = A(K,KK)                                              SYM00780
          T(2,2) = A(KK,KK) + A(L,L)                                    SYM00790
          T(2,3) = 0.                                                   SYM00800
          T(2,4) = T(1,3)                                               SYM00810
          T(3,1) = A(L,LL)                                              SYM00820
          T(3,2) = 0.                                                   SYM00830
          T(3,3) = A(K,K) + A(LL,LL)                                    SYM00840
          T(3,4) = T(1,2)                                               SYM00850
          T(4,1) = 0.                                                   SYM00860
          T(4,2) = T(3,1)                                               SYM00870
          T(4,3) = T(2,1)                                               SYM00880
          T(4,4) = A(KK,KK) + A(LL,LL)                                  SYM00890
          P(1) = C(K,L)                                                 SYM00900
          P(2) = C(KK,L)                                                SYM00910
          P(3) = C(K,LL)                                                SYM00920
          P(4) = C(KK,LL)                                               SYM00930
          NSYS = 4                                                      SYM00940
          CALL SYSSLV                                                   SYM00950
          C(K,L) = P(1)                                                 SYM00960
          C(KK,L) = P(2)                                                SYM00970
          C(K,LL) = P(3)                                                SYM00980
          C(KK,LL) = P(4)                                               SYM00990
  90    K = K + DK                                                      SYM01000
        IF(K .LE. N) GO TO 30                                           SYM01010
        LDL = L + DL                                                    SYM01020
        IF(LDL .GT. N) RETURN                                           SYM01030
        DO 120 J=LDL,N                                                  SYM01040
          DO 100 I=L,LL                                                 SYM01050
            C(I,J) = C(J,I)                                             SYM01060
  100     CONTINUE                                                      SYM01070
          DO 120 I=J,N                                                  SYM01080
            DO 110 K=L,LL                                               SYM01090
              C(I,J) = C(I,J) - C(I,K)*A(K,J) - A(K,I)*C(K,J)           SYM01100
  110     CONTINUE                                                      SYM01110
          C(J,I) = C(I,J)                                               SYM01120
  120 CONTINUE                                                          SYM01130
      L = LDL                                                           SYM01140
      GO TO 10                                                          SYM01150
      END                                                               SYM01160
      SUBROUTINE HSHLDR(A,N,NA)                                         HSH00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         HSH00020
      DIMENSION A(NA,1)                                                 HSH00030
      REAL*8 MAX                                                        HSH00040
C                                                                       HSH00050
      NM2 = N-2                                                         HSH00060
      N1 = N+1                                                          HSH00070
      IF(N .EQ. 1) RETURN                                               HSH00080
      IF(N .GT. 2) GO TO 5                                              HSH00090
      A(1,N1) = A(2,1)                                                  HSH00100
      RETURN                                                            HSH00110
    5 DO 80 L=1,NM2                                                     HSH00120
        L1 = L+1                                                        HSH00130
        MAX = 0.                                                        HSH00140
        DO 10 I=L1,N                                                    HSH00150
          MAX = DMAX1(MAX,DABS(A(I,L)))                                 HSH00160
   10   CONTINUE                                                        HSH00170
        IF(MAX .NE. 0.) GO TO 20                                        HSH00180
        A(L,N1) = 0.                                                    HSH00190
        A(N1,L) = 0.                                                    HSH00200
        GO TO 80                                                        HSH00210
   20   SUM = 0.                                                        HSH00220
        DO 30 I=L1,N                                                    HSH00230
          A(I,L) = A(I,L)/MAX                                           HSH00240
          SUM = SUM + A(I,L)**2                                         HSH00250
   30   CONTINUE                                                        HSH00260
        S = DSIGN(DSQRT(SUM),A(L1,L))                                   HSH00270
        A(L,N1) = -MAX*S                                                HSH00280
        A(L1,L) = S + A(L1,L)                                           HSH00290
        A(N1,L) = S*A(L1,L)                                             HSH00300
        DO 50 J=L1,N                                                    HSH00310
          SUM = 0.                                                      HSH00320
          DO 40 I=L1,N                                                  HSH00330
            SUM = SUM + A(I,L)*A(I,J)                                   HSH00340
   40     CONTINUE                                                      HSH00350
          P = SUM/A(N1,L)                                               HSH00360
          DO 50 I=L1,N                                                  HSH00370
            A(I,J) = A(I,J) - A(I,L)*P                                  HSH00380
   50   CONTINUE                                                        HSH00390
        DO 70 I=1,N                                                     HSH00400
          SUM = 0.                                                      HSH00410
          DO 60 J=L1,N                                                  HSH00420
            SUM = SUM + A(I,J)*A(J,L)                                   HSH00430
   60     CONTINUE                                                      HSH00440
          P = SUM/A(N1,L)                                               HSH00450
          DO 70 J=L1,N                                                  HSH00460
            A(I,J) = A(I,J) - P*A(J,L)                                  HSH00470
   70   CONTINUE                                                        HSH00480
   80 CONTINUE                                                          HSH00490
      A(N-1,N1) = A(N,N-1)                                              HSH00500
      RETURN                                                            HSH00510
      END                                                               HSH00520
      SUBROUTINE BCKMLT(A,U,N,NA,NU)                                    BCK00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         BCK00020
      DIMENSION                                                         BCK00030
     1A(NA,1),U(NU,1)                                                   BCK00040
C                                                                       BCK00050
      N1 = N+1                                                          BCK00060
      NM1 = N-1                                                         BCK00070
      NM2 = N-2                                                         BCK00080
      U(N,N) = 1.                                                       BCK00090
      IF(NM1 .EQ. 0) RETURN                                             BCK00100
      U(NM1,N) = 0.                                                     BCK00110
      U(N,NM1) = 0.                                                     BCK00120
      U(NM1,NM1) = 1.                                                   BCK00130
      IF(NM2 .EQ. 0) RETURN                                             BCK00140
      DO 40 LL=1,NM2                                                    BCK00150
        L = NM2-LL+1                                                    BCK00160
        L1 = L+1                                                        BCK00170
        IF(A(N1,L) .EQ. 0.) GO TO 25                                    BCK00180
        DO 20 J=L1,N                                                    BCK00190
          SUM = 0.                                                      BCK00200
          DO 10 I=L1,N                                                  BCK00210
            SUM = SUM + A(I,L)*U(I,J)                                   BCK00220
   10     CONTINUE                                                      BCK00230
          P = SUM/A(N1,L)                                               BCK00240
          DO 20 I=L1,N                                                  BCK00250
            U(I,J) = U(I,J) - A(I,L)*P                                  BCK00260
   20   CONTINUE                                                        BCK00270
   25   DO 30 I=L1,N                                                    BCK00280
          U(I,L) = 0.                                                   BCK00290
          U(L,I) = 0.                                                   BCK00300
   30   CONTINUE                                                        BCK00310
        U(L,L) = 1.                                                     BCK00320
   40 CONTINUE                                                          BCK00330
      RETURN                                                            BCK00340
      END                                                               BCK00350
      SUBROUTINE SCHUR(H,U,NN,NH,NU,EPS,FAIL)                           SCH00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         SCH00020
       DIMENSION                                                        SCH00030
     1H(NH,1),U(NU,1)                                                   SCH00040
      INTEGER                                                           SCH00050
     1 FAIL                                                             SCH00060
      LOGICAL                                                           SCH00070
     1LAST                                                              SCH00080
      N = NN                                                            SCH00090
      HN = 0.                                                           SCH00100
      DO 20 I=1,N                                                       SCH00110
        JL = MAX0(1,I-1)                                                SCH00120
        RSUM = 0.                                                       SCH00130
      DO 10 J=JL,N                                                      SCH00140
          RSUM = RSUM + DABS(H(I,J))                                    SCH00150
   10   CONTINUE                                                        SCH00160
        HN = DMAX1(HN,RSUM)                                             SCH00170
   20 CONTINUE                                                          SCH00180
      TEST = EPS*HN                                                     SCH00190
      IF(HN .EQ. 0.) GO TO 230                                          SCH00200
   30 IF(N .LE. 1) GO TO 230                                            SCH00210
      ITS = 0                                                           SCH00220
      NA = N-1                                                          SCH00230
      NM2 = N-2                                                         SCH00240
   40 DO 50 LL=2,N                                                      SCH00250
      L = N-LL+2                                                        SCH00260
        IF(DABS(H(L,L-1)) .LE. TEST) GO TO 60                           SCH00270
   50 CONTINUE                                                          SCH00280
      L = 1                                                             SCH00290
      GO TO 70                                                          SCH00300
   60 H(L,L-1) = 0.                                                     SCH00310
   70 IF(L .LT. NA) GO TO 72                                            SCH00320
      N = L-1                                                           SCH00330
      GO TO 30                                                          SCH00340
   72 X = H(N,N)/HN                                                     SCH00350
      Y = H(NA,NA)/HN                                                   SCH00360
      R = (H(N,NA)/HN)*(H(NA,N)/HN)                                     SCH00370
      IF(ITS .LT. 30) GO TO 75                                          SCH00380
      FAIL = N                                                          SCH00390
      RETURN                                                            SCH00400
   75 IF(ITS.EQ.10 .OR. ITS.EQ.20) GO TO 80                             SCH00410
      S = X + Y                                                         SCH00420
      Y = X*Y - R                                                       SCH00430
      GO TO 90                                                          SCH00440
   80 Y = (DABS(H(N,NA)) + DABS(H(NA,NM2)))/HN                          SCH00450
      S = 1.5*Y                                                         SCH00460
      Y = Y**2                                                          SCH00470
   90 ITS = ITS + 1                                                     SCH00480
      DO 100 MM=L,NM2                                                   SCH00490
        M = NM2-MM+L                                                    SCH00500
        X = H(M,M)/HN                                                   SCH00510
        R = H(M+1,M)/HN                                                 SCH00520
        Z = H(M+1,M+1)/HN                                               SCH00530
        P = X*(X-S) + Y + R*(H(M,M+1)/HN)                               SCH00540
        Q = R*(X+Z-S)                                                   SCH00550
        R = R*(H(M+2,M+1)/HN)                                           SCH00560
        W = DABS(P) + DABS(Q) + DABS(R)                                 SCH00570
        P = P/W                                                         SCH00580
        Q = Q/W                                                         SCH00590
        R = R/W                                                         SCH00600
        IF(M .EQ. L) GO TO 110                                          SCH00610
      IF(DABS(H(M,M-1))*(DABS(Q)+DABS(R)) .LE. DABS(P)*TEST)            SCH00620
     1GO TO 110                                                         SCH00630
  100 CONTINUE                                                          SCH00640
  110 M2 = M+2                                                          SCH00650
      M3 = M+3                                                          SCH00660
      DO 120 I=M2,N                                                     SCH00670
        H(I,I-2) = 0.                                                   SCH00680
  120 CONTINUE                                                          SCH00690
      IF(M3 .GT. N) GO TO 140                                           SCH00700
      DO 130 I=M3,N                                                     SCH00710
        H(I,I-3) = 0.                                                   SCH00720
  130 CONTINUE                                                          SCH00730
  140 DO 220 K=M,NA                                                     SCH00740
        LAST = K.EQ.NA                                                  SCH00750
        IF(K .EQ. M) GO TO 150                                          SCH00760
        P = H(K,K-1)                                                    SCH00770
        Q = H(K+1,K-1)                                                  SCH00780
        R = 0.                                                          SCH00790
        IF(.NOT.LAST) R = H(K+2,K-1)                                    SCH00800
        X = DABS(P) + DABS(Q) + DABS(R)                                 SCH00810
        IF(X .EQ. 0.) GO TO 220                                         SCH00820
        P = P/X                                                         SCH00830
        Q = Q/X                                                         SCH00840
        R = R/X                                                         SCH00850
  150   S = DSQRT(P**2 + Q**2 + R**2)                                   SCH00860
        IF(P .LT. 0.) S = -S                                            SCH00870
        IF(K .NE. M) H(K,K-1) = -S*X                                    SCH00880
        IF(K.EQ.M .AND. L.NE.M) H(K,K-1) = -H(K,K-1)                    SCH00890
        P = P + S                                                       SCH00900
        X = P/S                                                         SCH00910
        Y = Q/S                                                         SCH00920
        Z = R/S                                                         SCH00930
        Q = Q/P                                                         SCH00940
        R = R/P                                                         SCH00950
        DO 170 J=K,NN                                                   SCH00960
          P = H(K,J) + Q*H(K+1,J)                                       SCH00970
          IF(LAST) GO TO 160                                            SCH00980
          P = P + R*H(K+2,J)                                            SCH00990
          H(K+2,J) = H(K+2,J) - P*Z                                     SCH01000
  160     H(K+1,J) = H(K+1,J) - P*Y                                     SCH01010
          H(K,J) = H(K,J) - P*X                                         SCH01020
  170   CONTINUE                                                        SCH01030
        J = MIN0(K+3,N)                                                 SCH01040
        DO 190 I=1,J                                                    SCH01050
          P = X*H(I,K) + Y*H(I,K+1)                                     SCH01060
          IF(LAST) GO TO 180                                            SCH01070
          P = P + Z*H(I,K+2)                                            SCH01080
          H(I,K+2) = H(I,K+2) - P*R                                     SCH01090
  180     H(I,K+1) = H(I,K+1) - P*Q                                     SCH01100
          H(I,K) = H(I,K) - P                                           SCH01110
  190   CONTINUE                                                        SCH01120
        DO 210 I=1,NN                                                   SCH01130
          P = X*U(I,K) + Y*U(I,K+1)                                     SCH01140
          IF(LAST) GO TO 200                                            SCH01150
          P = P + Z*U(I,K+2)                                            SCH01160
          U(I,K+2) = U(I,K+2) - P*R                                     SCH01170
  200     U(I,K+1) = U(I,K+1) - P*Q                                     SCH01180
          U(I,K) = U(I,K) - P                                           SCH01190
  210   CONTINUE                                                        SCH01200
  220 CONTINUE                                                          SCH01210
      GO TO 40                                                          SCH01220
  230 FAIL = 0                                                          SCH01230
      RETURN                                                            SCH01240
      END                                                               SCH01250
      SUBROUTINE SYSSLV                                                 SYS00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         SYS00020
C                                                                       SYS00030
      COMMON/SLVBLK/A(5,5),B(5),N                                       SYS00040
      REAL*8 MAX                                                        SYS00050
    1 NM1 = N - 1                                                       SYS00060
      N1 = N+1                                                          SYS00070
C                                                                       SYS00080
C COMPUTE THE LU FACTORIZATION OF A.                                    SYS00090
      DO 80 K=1,N                                                       SYS00100
        KM1 = K-1                                                       SYS00110
        IF(K.EQ.1) GO TO 20                                             SYS00120
        DO 10 I=K,N                                                     SYS00130
          DO 10 J=1,KM1                                                 SYS00140
            A(I,K) = A(I,K) - A(I,J)*A(J,K)                             SYS00150
   10   CONTINUE                                                        SYS00160
   20   IF(K.EQ.N) GO TO 100                                            SYS00170
        KP1 = K+1                                                       SYS00180
      MAX = DABS(A(K,K))                                                SYS00190
        INTR = K                                                        SYS00200
        DO 30 I=KP1,N                                                   SYS00210
          AA = DABS(A(I,K))                                             SYS00220
          IF(AA .LE. MAX) GO TO 30                                      SYS00230
          MAX = AA                                                      SYS00240
          INTR = I                                                      SYS00250
   30   CONTINUE                                                        SYS00260
        IF(MAX .EQ. 0.) STOP                                            SYS00270
        A(N1,K) = INTR                                                  SYS00280
        IF(INTR .EQ. K) GO TO 50                                        SYS00290
        DO 40 J=1,N                                                     SYS00300
          TEMP = A(K,J)                                                 SYS00310
          A(K,J) = A(INTR,J)                                            SYS00320
          A(INTR,J) = TEMP                                              SYS00330
   40   CONTINUE                                                        SYS00340
   50   DO 80 J=KP1,N                                                   SYS00350
          IF(K.EQ.1) GO TO 70                                           SYS00360
          DO 60 I=1,KM1                                                 SYS00370
            A(K,J) = A(K,J) - A(K,I)*A(I,J)                             SYS00380
   60     CONTINUE                                                      SYS00390
   70     A(K,J) = A(K,J)/A(K,K)                                        SYS00400
   80 CONTINUE                                                          SYS00410
C                                                                       SYS00420
C INTERCHANGE THE COMPONENTS OF B.                                      SYS00430
C                                                                       SYS00440
  100 DO 110 J=1,NM1                                                    SYS00450
        INTR = A(N1,J)                                                  SYS00460
        IF(INTR .EQ. J) GO TO 110                                       SYS00470
        TEMP = B(J)                                                     SYS00480
        B(J) = B(INTR)                                                  SYS00490
        B(INTR) = TEMP                                                  SYS00500
  110 CONTINUE                                                          SYS00510
C                                                                       SYS00520
C SOLVE LX = B.                                                         SYS00530
C                                                                       SYS00540
  200 B(1) = B(1)/A(1,1)                                                SYS00550
      DO 220 I=2,N                                                      SYS00560
        IM1 = I-1                                                       SYS00570
        DO 210 J=1,IM1                                                  SYS00580
          B(I) = B(I) - A(I,J)*B(J)                                     SYS00590
  210   CONTINUE                                                        SYS00600
        B(I) = B(I)/A(I,I)                                              SYS00610
  220 CONTINUE                                                          SYS00620
C                                                                       SYS00630
C SOLVE UX = B.                                                         SYS00640
C                                                                       SYS00650
  300 DO 310 II=1,NM1                                                   SYS00660
          I = NM1-II+1                                                  SYS00670
        I1 = I+1                                                        SYS00680
        DO 310 J=I1,N                                                   SYS00690
          B(I) = B(I) - A(I,J)*B(J)                                     SYS00700
  310 CONTINUE                                                          SYS00710
      RETURN                                                            SYS00720
      END                                                               SYS00730
      SUBROUTINE RICNWT(A,NA,B,NB,H,NH,Q,NQ,R,NR,F,NF,P,NP,IOP,IDENT,DI RIC00010
     1SC,FNULL,DUMMY)                                                   RIC00020
      IMPLICIT REAL*8 (A-H,O-Z)                                         RIC00030
      DIMENSION A(1),B(1),Q(1),R(1),F(1),P(1),DUMMY(1)                  RIC00040
      DIMENSION NA(2),NB(2),NQ(2),NR(2),NF(2),NP(2),IOP(3)              RIC00050
      DIMENSION H(1),NH(2),IOPT(2)                                      RIC00060
      LOGICAL  IDENT,DISC,FNULL,SYM                                     RIC00070
      COMMON/TOL/EPSAM,EPSBM,IACM                                       RIC00080
      COMMON/CONV/SUMCV,RICTCV,SERCV,MAXSUM                             RIC00090
      I=1                                                               RIC00100
      IOPT(1)=0                                                         RIC00110
      SYM = .TRUE.                                                      RIC00120
C                                                                       RIC00130
      N = NA(1)**2                                                      RIC00140
      N1 = N +1                                                         RIC00150
      IF( .NOT. DISC) N1 = NA(1)*NR(1) + 1                              RIC00160
      N2= N1+N                                                          RIC00170
      N3= N2+N                                                          RIC00180
      N4 = N3+N                                                         RIC00190
C                                                                       RIC00200
      IF( IOP(1) .EQ. 0 )  GO TO 210                                    RIC00210
      CALL LNCNT(4)                                                     RIC00220
      IF(.NOT. DISC)PRINT 100                                           RIC00230
      IF( DISC )PRINT 150                                               RIC00240
  100 FORMAT(//,' PROGRAM TO SOLVE CONTINUOUS STEADY-STATE RICCATI EQUATRIC00250
     1ION BY THE NEWTON ALGORITHM',/)                                   RIC00260
  150 FORMAT(//,' PROGRAM TO SOLVE DISCRETE STEADY-STATE RICCATI EQUATIORIC00270
     1N BY THE NEWTON ALGORITHM',/)                                     RIC00280
      CALL PRNT(A,NA,4H A  ,1)                                          RIC00290
      CALL PRNT(B,NB,4H B  ,1)                                          RIC00300
      CALL PRNT(Q,NQ,4H Q  ,1)                                          RIC00310
      IF( .NOT. IDENT )GO TO 185                                        RIC00320
      CALL LNCNT(3)                                                     RIC00330
      PRINT 180                                                         RIC00340
  180 FORMAT(/,' H IS AN IDENTITY MATRIX',/)                            RIC00350
      GO TO 200                                                         RIC00360
  185 CONTINUE                                                          RIC00370
      CALL PRNT(H,NH,4H H  ,1)                                          RIC00380
      CALL MULT(Q,NQ,H,NH,DUMMY,NH)                                     RIC00390
      CALL TRANP(H,NH,DUMMY(N2),NP)                                     RIC00400
      CALL MULT(DUMMY(N2),NP,DUMMY,NH,Q,NQ)                             RIC00410
      CALL LNCNT(3)                                                     RIC00420
      PRINT 195                                                         RIC00430
  195 FORMAT(/,' MATRIX (H TRANSPOSE)QH ',/)                            RIC00440
      CALL PRNT(Q,NQ,4HHTQH,1)                                          RIC00450
  200 CONTINUE                                                          RIC00460
      CALL PRNT(R,NR,4H R  ,1)                                          RIC00470
      IF( FNULL )  GO TO 210                                            RIC00480
      CALL LNCNT(3)                                                     RIC00490
      PRINT 205                                                         RIC00500
  205 FORMAT(/,' INITIAL F MATRIX',/)                                   RIC00510
      CALL PRNT(F,NF,4H F  ,1)                                          RIC00520
C                                                                       RIC00530
  210 CONTINUE                                                          RIC00540
      IF((IOP(1) .NE. 0)  .OR. IDENT)  GO TO 220                        RIC00550
      CALL MULT(Q,NQ,H,NH,DUMMY,NH)                                     RIC00560
      CALL TRANP(H,NH,DUMMY(N2),NP)                                     RIC00570
      CALL MULT(DUMMY(N2),NP,DUMMY,NH,Q,NQ)                             RIC00580
  220 CONTINUE                                                          RIC00590
C                                                                       RIC00600
      IF (DISC) GO TO 900                                               RIC00610
C                                                                       RIC00620
      CALL TRANP(B,NB,P,NP)                                             RIC00630
      CALL EQUATE(R,NR,DUMMY,NR)                                        RIC00640
      CALL SYMPDS(NR(1),NR(1),DUMMY,NP(2),P,IOPT,IOPT,DET,ISCALE,DUMMY(NRIC00650
     11),IERR)                                                          RIC00660
      IF(IERR .EQ. 0) GO TO 250                                         RIC00670
      CALL LNCNT(3)                                                     RIC00680
      PRINT 225                                                         RIC00690
  225 FORMAT(/,' IN RICNWT, A MATRIX WHICH IS  NOT SYMMETRIC POSITIVE DERIC00700
     1FINITE HAS BEEN SUBMITTED TO  SYMPDS',/)                          RIC00710
      RETURN                                                            RIC00720
C                                                                       RIC00730
  250 CONTINUE                                                          RIC00740
      CALL EQUATE(P,NP,DUMMY,NF)                                        RIC00750
      CALL MULT(B,NB,DUMMY,NF,DUMMY(N1),NA)                             RIC00760
      CALL TRANP(DUMMY(N1),NA,DUMMY(N2),NA)                             RIC00770
      CALL ADD(DUMMY(N1),NA,DUMMY(N2),NA,DUMMY(N1),NA)                  RIC00780
      CALL SCALE(DUMMY(N1),NA,DUMMY(N1),NA,0.5)                         RIC00790
C                                                                       RIC00800
      IF(FNULL) GO TO 300                                               RIC00810
C                                                                       RIC00820
      CALL MULT(B,NB,F,NF,DUMMY(N2),NA)                                 RIC00830
      CALL SUBT(A,NA,DUMMY(N2),NA,DUMMY(N2),NA)                         RIC00840
      CALL TRANP(DUMMY(N2),NA,DUMMY(N3),NA)                             RIC00850
      CALL EQUATE(DUMMY(N3),NA,DUMMY(N2),NA)                            RIC00860
      CALL MULT(R,NR,F,NF,DUMMY(N3),NF)                                 RIC00870
      CALL TRANP(F,NF,P,NP)                                             RIC00880
      CALL MULT(P,NP,DUMMY(N3),NF,DUMMY(N4),NA)                         RIC00890
      CALL TRANP(DUMMY(N4),NA,DUMMY(N3),NA)                             RIC00900
      CALL ADD(DUMMY(N4),NA,DUMMY(N3),NA,DUMMY(N3),NA)                  RIC00910
      CALL SCALE(DUMMY(N3),NA,DUMMY(N3),NA,0.5)                         RIC00920
      CALL ADD(DUMMY(N3),NA,Q,NQ,P,NP)                                  RIC00930
      CALL SCALE(P,NP,P,NP,-1.0)                                        RIC00940
      GO TO 350                                                         RIC00950
C                                                                       RIC00960
  300 CONTINUE                                                          RIC00970
      CALL TRANP(A,NA,DUMMY(N2),NA)                                     RIC00980
      CALL SCALE(Q,NQ,P,NP,-1.0)                                        RIC00990
C                                                                       RIC01000
  350 CONTINUE                                                          RIC01010
      IF(IOP(3) .NE. 0) GO TO 400                                       RIC01020
      EPSA= EPSAM                                                       RIC01030
      CALL BARSTW(DUMMY(N2),NA,B,NB,P,NP,IOPT,SYM,EPSA,EPSA,DUMMY(N3))  RIC01040
      GO TO 450                                                         RIC01050
C                                                                       RIC01060
  400 CONTINUE                                                          RIC01070
      IOPT(2)=1                                                         RIC01080
      CALL BILIN(DUMMY(N2),NA,B,NB,P,NP,IOPT,SCLE,SYM,DUMMY(N3))        RIC01090
C                                                                       RIC01100
  450 CONTINUE                                                          RIC01110
      CALL EQUATE(P,NP,DUMMY(N2),NP)                                    RIC01120
      IF(IOP(2).EQ. 0) GO TO 550                                        RIC01130
      CALL LNCNT(3)                                                     RIC01140
      PRINT 500,I                                                       RIC01150
  500 FORMAT(/,' ITERATION  ',I5,/)                                     RIC01160
      CALL PRNT(P,NP,4H P  ,1)                                          RIC01170
C                                                                       RIC01180
  550 CONTINUE                                                          RIC01190
      CALL MULT(DUMMY(N1),NA,P,NP,DUMMY(N3),NA)                         RIC01200
      CALL MULT(P,NP,DUMMY(N3),NA,DUMMY(N4),NA)                         RIC01210
      CALL TRANP(DUMMY(N4),NA,P,NA)                                     RIC01220
      CALL ADD(P,NP,DUMMY(N4),NA,P,NP)                                  RIC01230
      CALL SCALE(P,NP,P,NP,0.5)                                         RIC01240
      CALL ADD(Q,NQ,P,NP,P,NP)                                          RIC01250
      CALL SCALE(P,NP,P,NP,-1.0)                                        RIC01260
      CALL SUBT(A,NA,DUMMY(N3),NA,DUMMY(N4),NA)                         RIC01270
      CALL TRANP(DUMMY(N4),NA,DUMMY(N3),NA)                             RIC01280
C                                                                       RIC01290
      IF(IOP(3) .NE. 0 ) GO TO 650                                      RIC01300
      CALL BARSTW(DUMMY(N3),NA,B,NB,P,NP,IOPT,SYM,EPSA,EPSA,DUMMY(N4))  RIC01310
      GO TO 675                                                         RIC01320
C                                                                       RIC01330
  650 CONTINUE                                                          RIC01340
      CALL BILIN(DUMMY(N3),NA,B,NB,P,NP,IOPT,SCLE,SYM,DUMMY(N4))        RIC01350
C                                                                       RIC01360
  675 CONTINUE                                                          RIC01370
      I=I+1                                                             RIC01380
      CALL MAXEL(DUMMY(N2),NA,ANORM1)                                   RIC01390
      CALL SUBT(P,NP,DUMMY(N2),NA,DUMMY(N3),NA)                         RIC01400
      CALL MAXEL(DUMMY(N3),NA,ANORM2)                                   RIC01410
      IF(ANORM1 .GT. 1.0) GO TO 700                                     RIC01420
      IF( ANORM2/ANORM1 .LT. RICTCV ) GO TO 800                         RIC01430
      GO TO 750                                                         RIC01440
C                                                                       RIC01450
  700 CONTINUE                                                          RIC01460
      IF( ANORM2 .LT. RICTCV ) GO TO 800                                RIC01470
C                                                                       RIC01480
  750 CONTINUE                                                          RIC01490
      IF( I .LE. 101) GO TO 450                                         RIC01500
      CALL LNCNT(3)                                                     RIC01510
      PRINT 775                                                         RIC01520
  775 FORMAT(/,' THE SUBROUTINE RICNWT HAS EXCEEDED 100 ITERATIONS WITHORIC01530
     1UT CONVERGENCE',/)                                                RIC01540
      IOP(1) = 1                                                        RIC01550
C                                                                       RIC01560
  800 CONTINUE                                                          RIC01570
      CALL MULT(DUMMY,NF,P,NP,F,NF)                                     RIC01580
      GO TO 1300                                                        RIC01590
C                                                                       RIC01600
  900 CONTINUE                                                         -RIC01610
      IF( .NOT. FNULL ) GO TO 950                                       RIC01620
C                                                                       RIC01630
      CALL EQUATE(Q,NQ,P,NP)                                            RIC01640
      CALL EQUATE(A,NA,DUMMY(N1),NA)                                    RIC01650
      CALL TRANP(A,NA,DUMMY(N2),NA)                                     RIC01660
      GO TO 1000                                                        RIC01670
  925 CONTINUE                                                          RIC01680
C                                                                       RIC01690
      I=I+1                                                             RIC01700
      CALL EQUATE(P,NP,DUMMY,NP)                                        RIC01710
  950 CONTINUE                                                          RIC01720
C                                                                       RIC01730
      CALL MULT(R,NR,F,NF,DUMMY(N1),NF)                                 RIC01740
      CALL TRANP(F,NF,P,NP)                                             RIC01750
      CALL MULT(P,NP,DUMMY(N1),NF,DUMMY(N2),NA)                         RIC01760
      CALL TRANP(DUMMY(N2),NA,DUMMY(N1),NA)                             RIC01770
      CALL ADD(DUMMY(N1),NA,DUMMY(N2),NA,DUMMY(N1),NA)                  RIC01780
      CALL SCALE(DUMMY(N1),NA,DUMMY(N1),NA,0.5)                         RIC01790
      CALL ADD(Q,NQ,DUMMY(N1),NA,P,NP)                                  RIC01800
      CALL MULT(B,NB,F,NF,DUMMY(N1),NA)                                 RIC01810
      CALL SUBT(A,NA,DUMMY(N1),NA,DUMMY(N1),NA)                         RIC01820
      CALL TRANP(DUMMY(N1),NA,DUMMY(N2),NA)                             RIC01830
C                                                                       RIC01840
 1000 CONTINUE                                                          RIC01850
      CALL SUM(DUMMY(N2),NA,P,NP,DUMMY(N1),NA,IOPT,SYM,DUMMY(N3))       RIC01860
      IF(IOP(2) .EQ. 0) GO TO 1100                                      RIC01870
      CALL LNCNT(3)                                                     RIC01880
      PRINT 500,I                                                       RIC01890
      CALL PRNT(P,NP,4H P  ,1)                                          RIC01900
C                                                                       RIC01910
 1100 CONTINUE                                                          RIC01920
      CALL MULT(P,NP,A,NA,DUMMY(N1),NA)                                 RIC01930
      CALL MULT(P,NP,B,NB,DUMMY(N2),NB)                                 RIC01940
      CALL TRANP(B,NB,DUMMY(N3),NF)                                     RIC01950
      CALL MULT(DUMMY(N3),NF,DUMMY(N1),NA,F,NF)                         RIC01960
      CALL MULT(DUMMY(N3),NF,DUMMY(N2),NB,DUMMY(N1),NR)                 RIC01970
      CALL TRANP(DUMMY(N1),NR,DUMMY(N2),NR)                             RIC01980
      CALL ADD(DUMMY(N1),NR,DUMMY(N2),NR,DUMMY(N1),NR)                  RIC01990
      CALL SCALE(DUMMY(N1),NR,DUMMY(N1),NR,0.5)                         RIC02000
      CALL ADD(R,NR,DUMMY(N1),NR,DUMMY(N1),NR)                          RIC02010
      CALL SYMPDS(NR(1),NR(1),DUMMY(N1),NA(1),F,IOPT,IOPT,DET,ISCALE,DUMRIC02020
     1MY(N2),IERR)                                                      RIC02030
      IF(IERR .EQ. 0) GO TO 1150                                        RIC02040
      CALL LNCNT(3)                                                     RIC02050
      PRINT 225                                                         RIC02060
      RETURN                                                            RIC02070
C                                                                       RIC02080
 1150 CONTINUE                                                          RIC02090
      IF( I .EQ. 1) GO TO 925                                           RIC02100
      CALL MAXEL(DUMMY,NA,ANORM1)                                       RIC02110
      CALL SUBT(P,NP,DUMMY,NA,DUMMY(N1),NA)                             RIC02120
      CALL MAXEL(DUMMY(N1),NA,ANORM2)                                   RIC02130
      IF( ANORM1 .GT. 1.) GO TO 1200                                    RIC02140
      IF( ANORM2/ANORM1 .LT. RICTCV ) GO TO 1300                        RIC02150
      GO TO 1250                                                        RIC02160
 1200 CONTINUE                                                          RIC02170
      IF( ANORM2 .LT. RICTCV ) GO TO 1300                               RIC02180
C                                                                       RIC02190
 1250 CONTINUE                                                          RIC02200
      IF( I .LE. 101) GO TO  925                                        RIC02210
      CALL LNCNT(3)                                                     RIC02220
      PRINT 775                                                         RIC02230
      IOP(1) = 1                                                        RIC02240
C                                                                       RIC02250
 1300 CONTINUE                                                          RIC02260
      IF(IOP(1) .EQ. 0 ) RETURN                                         RIC02270
      CALL LNCNT(4)                                                     RIC02280
      PRINT 1350,I                                                      RIC02290
 1350 FORMAT(//,' FINAL VALUES OF P AND F AFTER',I5,' ITERATIONS TO CONVRIC02300
     1ERGE',/)                                                          RIC02310
      CALL PRNT(P,NP,4H P  ,1)                                          RIC02320
      CALL PRNT(F,NF,4H F  ,1)                                          RIC02330
C                                                                       RIC02340
      RETURN                                                            RIC02350
      END                                                               RIC02360
      SUBROUTINE SUM(A,NA,B,NB,C,NC,IOP,SYM,DUMMY)                      SUM00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         SUM00020
      DIMENSION A(1),B(1),C(1),DUMMY(1)                                 SUM00030
      DIMENSION NA(2),NB(2),NC(2)                                       SUM00040
      LOGICAL SYM                                                       SUM00050
      COMMON/CONV/SUMCV,RICTCV,SERCV,MAXSUM                             SUM00060
      IF( IOP  .EQ. 0  ) GO TO 100                                      SUM00070
      PRINT 50                                                          SUM00080
   50 FORMAT(//,' LINEAR EQUATION SOLVER    X = AXC + B ')              SUM00090
      CALL PRNT(A,NA,4H A  ,1)                                          SUM00100
      IF( SYM ) GO TO 75                                                SUM00110
      CALL PRNT(C,NC,4H C  ,1)                                          SUM00120
      GO TO 85                                                          SUM00130
   75 CONTINUE                                                          SUM00140
      PRINT 80                                                          SUM00150
   80 FORMAT(/, ' C = A TRANSPOSE ',/)                                  SUM00160
   85 CONTINUE                                                          SUM00170
      CALL PRNT(B,NB,4H B  ,1)                                          SUM00180
C                                                                       SUM00190
  100 CONTINUE                                                          SUM00200
      N1 = 1 + NA(1)*NC(1)                                              SUM00210
      I=1                                                               SUM00220
  200 CONTINUE                                                          SUM00230
      CALL MULT(A,NA,B,NB,DUMMY,NB)                                     SUM00240
      CALL MULT(DUMMY,NB,C,NC,DUMMY(N1),NB)                             SUM00250
      CALL MAXEL(B,NB,WNS)                                              SUM00260
      CALL MAXEL(DUMMY(N1),NB,WNDX)                                     SUM00270
      IF(WNS .GE. 1.) GO TO 225                                         SUM00280
      IF( WNDX/WNS .LT. SUMCV ) GO TO 300                               SUM00290
      GO TO 235                                                         SUM00300
  225 IF( WNDX .LT. SUMCV ) GO TO 300                                   SUM00310
  235 CONTINUE                                                          SUM00320
      CALL ADD(B,NB,DUMMY(N1),NB,B,NB)                                  SUM00330
      CALL MULT(A,NA,A,NA,DUMMY,NA)                                     SUM00340
      CALL EQUATE(DUMMY,NA,A,NA)                                        SUM00350
      IF( SYM ) GO TO 245                                               SUM00360
      CALL MULT(C,NC,C,NC,DUMMY,NC)                                     SUM00370
      CALL EQUATE(DUMMY,NC,C,NC)                                        SuM00380
      GO TO  250                                                        SUM00390
  245 CONTINUE                                                          SUM00400
      CALL TRANP(A,NA,C,NC)                                             SUM00410
  250 CONTINUE                                                          SUM00420
      I=I+1                                                             SUM00430
      IF( I .LE. MAXSUM ) GO TO 200                                     SUM00440
      CALL LNCNT(3)                                                     SUM00450
      PRINT 275,MAXSUM                                                  SUM00460
  275 FORMAT(//,' IN SUM, THE SEQUENCE OF PARTIAL SUMS HAS EXCEEDED STAGSUM00470
     1 E',I5,' WITHOUT CONVERGENCE')                                    SUM00480
  300 CONTINUE                                                          SUM00490
      IF(IOP .EQ. 0) RETURN                                             SUM00500
      CALL PRNT(B,NB,4H X  ,1)                                          SUM00510
      RETURN                                                            SUM00520
      END                                                               SUM00530
      SUBROUTINE BILIN(A,NA,B,NB,C,NC,IOP,BETA,SYM,DUMMY)               BIL00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         BIL00020
      DIMENSION A(1),B(1),C(1),DUMMY(1)                                 BIL00030
      DIMENSION NA(2),NB(2),NC(2),NDUM(2)                               BIL00040
      DIMENSION IOP(2)                                                  BIL00050
      LOGICAL SYM                                                       BIL00060
      IF( IOP(1) .EQ. 0 )  GO TO 300                                    BIL00070
      IF(SYM) GO TO 100                                                 BIL00080
      CALL LNCNT(3)                                                     BIL00090
      PRINT 50                                                          BIL00100
   50 FORMAT(//,' LINEAR EQUATION SOLVER  AX + XB = C ')                BIL00110
      CALL PRNT(A,NA,4H A  ,1)                                          BIL00120
      CALL PRNT(B,NB,4H B  ,1)                                          BIL00130
      GO TO 200                                                         BIL00140
  100 CONTINUE                                                          BIL00150
      CALL LNCNT(3)                                                     BIL00160
      PRINT 150                                                         BIL00170
  150 FORMAT(//,' LINEAR EQUATION SOLVER  ( B TRANSPOSE )X + XB = C ')  BIL00180
      CALL TRANP(A,NA,DUMMY,NDUM)                                       BIL00190
      CALL PRNT(DUMMY,NDUM,4H B  ,1)                                    BIL00200
  200 CONTINUE                                                          BIL00210
      CALL PRNT(C,NC,4H C  ,1)                                          BIL00220
  300 CONTINUE                                                          BIL00230
C                                                                       BIL00240
      IOPTT = 0                                                         BIL00250
      N=NA(1)**2                                                        BIL00260
      M=NB(1)**2                                                        BIL00270
C                                                                       BIL00280
      IF( IOP(2) .EQ. 0 )  GO TO 500                                    BIL00290
C                                                                       BIL00300
      N1 = N + 1                                                        BIL00310
      CALL EQUATE(A,NA,DUMMY,NA)                                        BIL00320
      N2 = N1 + NA(1)                                                   BIL00330
      N3 = N2 + NA(1)                                                   BIL00340
      ISV = 0                                                           BIL00350
      ILV = 0                                                           BIL00360
      NEVL = NA(1)                                                      BIL00370
      CALL EIGEN(NA(1),NA(1),DUMMY,DUMMY(N1),DUMMY(N2),ISV,ILV,V,DUMMY(NBIL00380
     13),IERR)                                                          BIL00390
      IF (IERR .EQ. 0) GO TO 350                                        BIL00400
      CALL LNCNT(3)                                                     BIL00410
      PRINT 325,IERR                                                    BIL00420
  325 FORMAT(//,' IN BILIN, THE ',I4,' EIGENVALUE OF A HAS NOT BEEN  DETBIL00430
     1ERMINED AFTER 30 ITERATIONS')                                     BIL00440
      IERR=1                                                            BIL00450
      CALL NORMS(NEVL,NEVL,NEVL,A,IERR,BETA)                            BIL00460
      BETA=2.*BETA                                                      BIL00470
      GO TO 385                                                         BIL00480
  350 CONTINUE                                                          BIL00490
      J= N1 + NEVL -1                                                   BIL00500
      K = N2 + NEVL -1                                                  BIL00510
      CO = DSQRT(DUMMY(N1)**2 + DUMMY(N2)**2)                           BIL00520
      CN = DSQRT(DUMMY(J)**2 + DUMMY(K)**2)                             BIL00530
      CD = DUMMY(J)-DUMMY(N1)                                           BIL00540
      IF(CD .EQ. 0.0)  GO TO 365                                        BIL00550
      BETA = (DUMMY(N1)*CN-DUMMY(J)*CO)/CD                              BIL00560
      IF(BETA .LE. 0.0)  GO TO 365                                      BIL00570
      BETA = DSQRT(BETA)                                                BIL00580
      GO TO 385                                                         BIL00590
C                                                                       BIL00600
  365 CONTINUE                                                          BIL00610
C                                                                       BIL00620
      BETA = 0.0                                                        BIL00630
      DO 375 I = 1,NEVL                                                 BIL00640
      J = N1 + I -1                                                     BIL00650
      K = N2 + I -1                                                     BIL00660
      IF(DUMMY(J) .GE. 0.0)  GO TO 375                                  BIL00670
      BETA = BETA + DSQRT(DUMMY(J)**2 + DUMMY(K)**2)                    BIL00680
  375 CONTINUE                                                          BIL00690
      BETA = BETA/NEVL                                                  BIL00700
C                                                                       BIL00710
  385 CONTINUE                                                          BIL00720
C                                                                       BIL00730
      IF( SYM ) GO TO 500                                               BIL00740
      CALL EQUATE(B,NB,DUMMY,NB)                                        BIL00750
      N1=M+1                                                            BIL00760
      N2 = N1 +NB(1)                                                    BIL00770
      N3 = N2 +NB(1)                                                    BIL00780
      NEVL = NB(1)                                                      BIL00790
      CALL EIGEN(NB(1),NB(1),DUMMY,DUMMY(N1),DUMMY(N2),ISV,ILV,V,DUMMY(NBIL00800
     13),IERR)                                                          BIL00810
      IF(IERR .EQ. 0) GO TO 450                                         BIL00820
      CALL LNCNT(3)                                                     BIL00830
      PRINT 400,IERR                                                    BIL00840
  400 FORMAT(//,' IN BILIN, THE ',I4,' EIGENVALUE OF B HAS NOT BEEN FOUNBIL00850
     1D AFTER 30 ITERATIONS')                                           BIL00860
      IERR=1                                                            BIL00870
      CALL NORMS(NEVL,NEVL,NEVL,B,IERR,BETA1)                           BIL00880
      BETA1=2.*BETA1                                                    BIL00890
      GO TO 485                                                         BIL00900
  450 CONTINUE                                                          BIL00910
      J = N1 + NEVL -1                                                  BIL00920
      K = N2 + NEVL -1                                                  BIL00930
      CO = DSQRT(DUMMY(N1)**2 + DUMMY(N2)**2)                           BIL00940
      CN = DSQRT(DUMMY(J)**2 + DUMMY(K)**2)                             BIL00950
      CD = DUMMY(J)-DUMMY(N1)                                           BIL00960
      IF(CD .EQ. 0.0)  GO TO 465                                        BIL00970
      BETA1 = (DUMMY(N1)*CN - DUMMY(J)*CO)/CD                           BIL00980
      IF(BETA1 .LE. 0.0)  GO TO 465                                     BIL00990
      BETA1 = DSQRT(BETA1)                                              BIL01000
      GO TO 485                                                         BIL01010
C                                                                       BIL01020
  465 CONTINUE                                                          BIL01030
C                                                                       BIL01040
      BETA1 = 0.0                                                       BIL01050
      DO 475 I= 1,NEVL                                                  BIL01060
      J = N1 + I -1                                                     BIL01070
      K = N2 + I -1                                                     BIL01080
      IF(DUMMY(J) .GE. 0.0)  GO TO 475                                  BIL01090
      BETA1 = BETA1 + DSQRT(DUMMY(J)**2 + DUMMY(K)**2)                  BIL01100
  475 CONTINUE                                                          BIL01110
      BETA1 = BETA1/NEVL                                                BIL01120
C                                                                       BIL01130
  485 CONTINUE                                                          BIL01140
      BETA = (BETA + BETA1)/2.                                          BIL01150
C                                                                       BIL01160
  500 CONTINUE                                                          BIL01170
C                                                                       BIL01180
C                                                                       BIL01190
      IF( IOP(1) .EQ. 0 )  GO TO 520                                    BIL01200
      CALL LNCNT(4)                                                     BIL01210
      PRINT 515,BETA                                                    BIL01220
  515 FORMAT(//,' BETA = ',E16.8,/)                                     BIL01230
  520 CONTINUE                                                          BIL01240
C                                                                       BIL01250
      N1 = N+1                                                          BIL01260
      CALL EQUATE(A,NA,DUMMY,NA)                                        BIL01270
      CALL EQUATE(A,NA,DUMMY(N1),NA)                                    BIL01280
      CALL SCALE(DUMMY,NA,DUMMY,NA,-1.)                                 BIL01290
      L = -NA(1)                                                        BIL01300
      NAX = NA(1)                                                       BIL01310
      DO 525 I=1,NAX                                                    BIL01320
      L = L + NAX +1                                                    BIL01330
      M1 = L + N                                                        BIL01340
      DUMMY(L) = BETA - A(L)                                            BIL01350
      DUMMY(M1)= BETA + A(L)                                            BIL01360
  525 CONTINUE                                                          BIL01370
      N2 = N1 + N                                                       BIL01380
      CALL EQUATE(C,NC,DUMMY(N2),NDUM)                                  BIL01390
      NDUM(2)= NDUM(2) + NA(1)                                          BIL01400
      N3 = N2 + NC(1)*NC(2)                                             BIL01410
      GAM = -2.*BETA                                                    BIL01420
C                                                                       BIL01430
      IF( .NOT. SYM ) GO  TO 600                                        BIL01440
C                                                                       BIL01450
      CALL UNITY(DUMMY(N3),NA)                                          BIL01460
      N4 = N3 + N                                                       BIL01470
      NDUM(2) = NDUM(2) + NA(1)                                         BIL01480
      N5 = N4 + NA(1)                                                   BIL01490
      IFAC = 0                                                          BIL01500
      CALL GELIM(NA(1),NA(1),DUMMY,NDUM(2),DUMMY(N1),DUMMY(N4),IFAC,DUMMBIL01510
     1Y(N5),IERR)                                                       BIL01520
      IF( IERR .EQ. 1 )  PRINT 625                                      BIL01530
      CALL EQUATE(DUMMY(N1),NA,DUMMY,NA)                                BIL01540
      CALL EQUATE(DUMMY(N2),NC,C,NC)                                    BIL01550
      CALL TRANP(DUMMY,NA,DUMMY(N1),NA)                                 BIL01560
      CALL TRANP(DUMMY(N3),NA,DUMMY(N2),NA)                             BIL01570
      CALL MULT(C,NC,DUMMY(N2),NA,DUMMY(N3),NA)                         BIL01580
      CALL SCALE(DUMMY(N3),NC,C,NC,GAM)                                 BIL01590
C                                                                       BIL01600
C                                                                       BIL01610
      CALL SUM(DUMMY,NA,C,NC,DUMMY(N1),NA,IOPTT,SYM,DUMMY(N2))          BIL01620
      GO TO 700                                                         BIL01630
  600 CONTINUE                                                          BIL01640
      N4 = N3 +NA(1)                                                    BIL01650
      IFAC = 0                                                          BIL01660
      CALL GELIM(NA(1),NA(1),DUMMY,NDUM(2),DUMMY(N1),DUMMY(N3),IFAC,DUMMBIL01670
     1Y(N4),IERR)                                                       BIL01680
      IF(IERR .EQ. 1 ) PRINT 625                                        BIL01690
  625 FORMAT(//,' IN BILIN, THE MATRIX  (BETA)I - A IS SINGULAR, INCREASBIL01700
     1E BETA ')                                                         BIL01710
      CALL EQUATE(DUMMY(N1),NA,DUMMY,NA)                                BIL01720
      CALL EQUATE(DUMMY(N2),NC,C,NC)                                    BIL01730
      N2 = M + N1                                                       BIL01740
      CALL EQUATE(B,NB,DUMMY(N1),NB)                                    BIL01750
      CALL EQUATE(B,NB,DUMMY(N2),NB)                                    BIL01760
      CALL SCALE(DUMMY(N1),NB,DUMMY(N1),NB,-1.0)                        BIL01770
      L=-NB(1)                                                          BIL01780
      NAX=NB(1)                                                         BIL01790
      DO650I =1,NAX                                                     BIL01800
      L=L + NAX +1                                                      BIL01810
      L1 = L + N                                                        BIL01820
      M1 = L + N2-1                                                     BIL01830
      DUMMY(L1)= BETA- B(L)                                             BIL01840
      DUMMY(M1)= BETA + B(L)                                            BIL01850
  650 CONTINUE                                                          BIL01860
C                                                                       BIL01870
      N3 = N2 + M                                                       BIL01880
      CALL TRANP(DUMMY(N1),NB,DUMMY(N3),NB)                             BIL01890
      CALL EQUATE(DUMMY(N3),NB,DUMMY(N1),NB)                            BIL01900
      CALL TRANP(DUMMY(N2),NB,DUMMY(N3),NB)                             BIL01910
      CALL EQUATE(DUMMY(N3),NB,DUMMY(N2),NB)                            BIL01920
      CALL TRANP(C,NC,DUMMY(N3),NDUM)                                   BIL01930
      NSDUM = NDUM(2)                                                   BIL01940
      NDUM(2)= NDUM(2) + NB(2)                                          BIL01950
      IFAC = 0                                                          BIL01960
      N4=N3+NC(1)*NC(2)                                                 BIL01970
      N5=N4+NB(1)                                                       BIL01980
      CALL GELIM(NB(1),NB(1),DUMMY(N1),NDUM(2),DUMMY(N2),DUMMY(N4),IFAC,BIL01990
     1DUMMY(N5),IERR)                                                   BIL02000
      IF(IERR .EQ. 1 )  PRINT 675                                       BIL02010
  675 FORMAT(//,'IN BILIN, THE MATRIX (BETA)I - B  IS SINGULAR, INCREASEBIL02020
     1 BETA ')                                                          BIL02030
      CALL TRANP(DUMMY(N2),NB,DUMMY(N1),NB)                             BIL02040
      NDUM(2)= NSDUM                                                    BIL02050
      CALL TRANP(DUMMY(N3),NDUM,C,NC)                                   BIL02060
      CALL SCALE(C,NC,C,NC,GAM)                                         BIL02070
      N2 = N + M + 1                                                    BIL02080
      CALL SUM(DUMMY,NA,C,NC,DUMMY(N1),NB,IOPTT,SYM,DUMMY(N2))          BIL02090
C                                                                       BIL02100
  700 CONTINUE                                                          BIL02110
      IF( IOP(1) .EQ. 0 ) RETURN                                        BIL02120
      CALL PRNT(C,NC,4H X  ,1)                                          BIL02130
      RETURN                                                            BIL02140
      END                                                               BIL02150
      SUBROUTINE BARSTW(A,NA,B,NB,C,NC,IOP,SYM,EPSA,EPSB,DUMMY)         BAR00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         BAR00020
      DIMENSION A(1),B(1),C(1),DUMMY(1)                                 BAR00030
      DIMENSION NA(2),NB(2),NC(2),NDUM1(2),NDUM2(2),NDUM3(2),NDUM4(2)   BAR00040
      LOGICAL  SYM                                                      BAR00050
      IF ( IOP .EQ. 0 )  GO TO 250                                      BAR00060
      IF(SYM) GO TO 100                                                 BAR00070
      CALL LNCNT(3)                                                     BAR00080
      PRINT 50                                                          BAR00090
   50 FORMAT(//,' LINEAR EQUATION SOLVER     AX + XB = C ')             BAR00100
      CALL PRNT(A,NA,4H A  ,1)                                          BAR00110
      CALL PRNT(B,NB,4H B  ,1)                                          BAR00120
      GO TO 200                                                         BAR00130
  100 CONTINUE                                                          BAR00140
      CALL LNCNT(3)                                                     BAR00150
      PRINT 150                                                         BAR00160
  150 FORMAT(//,' LINEAR EQUATION SOLVER  ( B TRANSPOSE )X + XB = C')   BAR00170
      CALL TRANP(A,NA,DUMMY,NDUM1)                                      BAR00180
      CALL PRNT(DUMMY,NDUM1,4H B  ,1)                                   BAR00190
  200 CONTINUE                                                          BAR00200
      CALL PRNT(C,NC,4H C  ,1)                                          BAR00210
C                                                                       BAR00220
  250 CONTINUE                                                          BAR00230
      CALL EQUATE(A,NA,DUMMY,NDUM1)                                     BAR00240
      N1=(NA(1)**2)+1                                                   BAR00250
      N2=N1+NA(1)-1                                                     BAR00260
      DO 300I=N1,N2                                                     BAR00270
      DUMMY(I)=0.0                                                      BAR00280
  300 CONTINUE                                                          BAR00290
C                                                                       BAR00300
      NDUM1(2)=NDUM1(2)+1                                               BAR00310
      NDUM2(1)=1                                                        BAR00320
      NDUM2(2)=NDUM1(2)                                                 BAR00330
      N1=NDUM1(1)*NDUM1(2)+1                                            BAR00340
      CALL NULL(DUMMY(N1),NDUM2)                                        BAR00350
      LU=(NA(1)+1)**2 + 1                                               BAR00360
      CALL JUXTR(DUMMY,NDUM1,DUMMY(N1),NDUM2,DUMMY(LU),NDUM3)           BAR00370
      CALL EQUATE(DUMMY(LU),NDUM3,DUMMY,NDUM1)                          BAR00380
      N=NA(1)+1                                                         BAR00390
C                                                                       BAR00400
      IF(SYM ) GO TO 500                                                BAR00410
C                                                                       BAR00420
      CALL EQUATE(B,NB,DUMMY(LU),NDUM2)                                 BAR00430
      M1=LU+NB(1)**2                                                    BAR00440
      M2=M1+NB(1)-1                                                     BAR00450
      DO400I=M1,M2                                                      BAR00460
      DUMMY(I)=0.0                                                      BAR00470
  400 CONTINUE                                                          BAR00480
C                                                                       BAR00490
      NDUM2(2)=NDUM2(2)+1                                               BAR00500
      NDUM3(1)=1                                                        BAR00510
      NDUM3(2)=NDUM2(2)                                                 BAR00520
      M1=NDUM2(1)*NDUM2(2)+LU                                           BAR00530
      CALL NULL(DUMMY(M1),NDUM3)                                        BAR00540
      M2=LU+(NB(1)+1)**2                                                BAR00550
      CALL JUXTR(DUMMY(LU),NDUM2,DUMMY(M1),NDUM3,DUMMY(M2),NDUM4)       BAR00560
      CALL EQUATE(DUMMY(M2),NDUM4,DUMMY(LU),NDUM2)                      BAR00570
      M=NB(1)+ 1                                                        BAR00580
      LNB = LU                                                          BjR00590
      LU = LU + (NB(1)+1)**2                                            BAR00600
      LV = LU +  NA(1)**2                                               BAR00610
      CALL AXPXB(DUMMY,DUMMY(LU),NA(1),N,NA(1),DUMMY(LNB),DUMMY(LV),NB(1BAR00620
     1),M,NB(1),C,NC(1),EPSA,EPSB,NFAIL)                                BAR00630
      GO TO 600                                                         BAR00640
C                                                                       BAR00650
  500 CONTINUE                                                          BAR00660
      CALL TRANP(DUMMY,NDUM1,DUMMY(LU),NDUM2)                           BAR00670
      CALL EQUATE(DUMMY(LU),NDUM2,DUMMY,NDUM1)                          BAR00680
      CALL ATXPXA(DUMMY,DUMMY(LU),C,NA(1),N,NA(1),NC(1),EPSA,NFAIL)     BAR00690
C                                                                       BAR00700
  600 CONTINUE                                                          BAR00710
      IF(NFAIL .EQ. 0 ) GO TO 700                                       BAR00720
      CALL LNCNT(3)                                                     BAR00730
      PRINT 650                                                         BAR00740
  650 FORMAT(//,' IN BARSTW, EITHER THE SUBROUTINE AXPXB  OR  ATXPXA  WABAR00750
     1S UNABLE TO REDUCE A OR B TO SCHUR FORM ')                        BAR00760
      RETURN                                                            BAR00770
C                                                                       BAR00780
  700 CONTINUE                                                          BAR00790
C                                                                       BAR00800
      IF( IOP .NE. 0 )  CALL PRNT(C,NC,4H  X ,1)                        BAR00810
      RETURN                                                            BAR00820
      END                                                               BAR00830
      SUBROUTINE TESTSA(A,NA,ALPHA,DISC,STABLE,IOP,DUMMY)               TES00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         TES00020
      DIMENSION A(1),DUMMY(1)                                           TES00030
      DIMENSION NA(2),NDUM1(2),NDUM2(2)                                 TES00040
      LOGICAL  DISC,STABLE                                              TES00050
      STABLE = .FALSE.                                                  TES00060
C                                                                       TES00070
      CALL EQUATE(A,NA,DUMMY,NA)                                        TES00080
      N1= NA(1)**2 + 1                                                  TES00090
      N2= N1+NA(1)                                                      TES00100
      N3= N2+NA(1)                                                      TES00110
      ISV = 0                                                           TES00120
      CALL EIGEN(NA(1),NA(1),DUMMY,DUMMY(N1),DUMMY(N2),ISV,ISV,V,DUMMY(NTES00130
     13),IERR)                                                          TES00140
      NEVL = NA(1)                                                      TES00150
      IF( IERR .EQ. 0 ) GO TO 200                                       TES00160
      CALL LNCNT(4)                                                     TES00170
      PRINT 100,IERR                                                    TES00180
  100 FORMAT(//,' IN TESTSA, THE ',I5,' EIGENVALUE OF A HAS NOT BEEN FO TES00190
     1UND AFTER 30 ITERATIONS',/)                                       TES00200
      RETURN                                                            TES00210
C                                                                       TES00220
  200 CONTINUE                                                          TES00230
      NDUM1(1) = NEVL                                                   TES00240
      NDUM1(2) = 1                                                      TES00250
      CALL JUXTC(DUMMY(N1),NDUM1,DUMMY(N2),NDUM1,DUMMY,NDUM2)           TES00260
C                                                                       TES00270
      IF( DISC ) GO TO 400                                              TES00280
      DO 300 I=1,NEVL                                                   TES00290
      IF( DUMMY(I) .GE. ALPHA ) GO TO 600                               TES00300
  300 CONTINUE                                                          TES00310
      GO TO 550                                                         TES00320
  400 CONTINUE                                                          TES00330
      N = NDUM2(1)*NDUM2(2)+1                                           TES00340
      DO 500 I =1,NEVL                                                  TES00350
      K = I + NEVL                                                      TES00360
      L=N +I -1                                                         TES00370
      DUMMY(L) = DSQRT((DUMMY(I)**2)+(DUMMY(K)**2))                     TES00380
  500 CONTINUE                                                          TES00390
C                                                                       TES00400
      IF( DUMMY(L) .GE. ALPHA ) GO TO 600                               TES00410
C                                                                       TES00420
  550 CONTINUE                                                          TES00430
      STABLE =.TRUE.                                                    TES00440
  600 CONTINUE                                                          TES00450
      IF( IOP .EQ. 0 ) RETURN                                           TES00460
      CALL LNCNT(4)                                                     TES00470
      PRINT 700                                                         TES00480
  700 FORMAT(//,' PROGRAM TO TEST THE RELATIVE STABILITY OF THE MATRIX ATES00490
     1',/)                                                              TES00500
      CALL PRNT(A,NA,4H A  ,1)                                          TES00510
      CALL LNCNT(4)                                                     TES00520
      PRINT 750                                                         TES00530
  750 FORMAT(//,' EIGENVALUES OF A ',/)                                 TES00540
      CALL PRNT(DUMMY,NDUM2,4HEVLA,1)                                   TES00550
      IF(  .NOT. DISC ) GO TO 850                                       TES00560
      CALL LNCNT(4)                                                     TES00570
      PRINT 800                                                         TES00580
  800 FORMAT(//,' MODULI OF EIGENVALUES OF A',/)                        TES00590
      CALL PRNT(DUMMY(N),NDUM1,4HMODA,1)                                TES00600
C                                                                       TES00610
  850 CONTINUE                                                          TES00620
      CALL LNCNT(4)                                                     TES00630
      IF(STABLE) PRINT 900,ALPHA                                        TES00640
      IF( .NOT. STABLE) PRINT 950,ALPHA                                 TES00650
  900 FORMAT(//,' MATRIX A  IS STABLE RELATIVE TO ',E16.8,/)            TES00660
  950 FORMAT(//,' MATRIX A  IS UNSTABLE RELATIVE TO ',E16.8,/)          TES00670
C                                                                       TES00680
      RETURN                                                            TES00690
      END                                                               TES00700
      SUBROUTINE EXPINT(A,NA,B,NB,C,NC,T,IOP,DUMMY)                     EXP00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         EXP00020
      DIMENSION A(1),B(1),C(1),DUMMY(1)                                 EXP00030
      DIMENSION NA(2),NB(2),NC(2)                                       EXP00040
      COMMON/CONV/SUMCV,RICTCV,SERCV,MAXSUM                             EXP00050
      N = NA(1)                                                         EXP00060
      L = (N**2)+1                                                      EXP00070
      NC(1) = NA(1)                                                     EXP00080
      NC(2) = NA(2)                                                     EXP00090
      NB(1) = NA(1)                                                     EXP00100
      NB(2) = NA(2)                                                     EXP00110
      TT = T                                                            EXP00120
C                                                                       EXP00130
      IOPT = 1                                                          EXP00140
      CALL NORMS(N,N,N,A,IOPT,COL)                                      EXP00150
      IOPT = 3                                                          EXP00160
      CALL NORMS(N,N,N,A,IOPT,ROW)                                      EXP00170
      ANAA = COL                                                        EXP00180
      IF( ANAA .GT. ROW )  ANAA = ROW                                   EXP00190
      TMAX = 1./ANAA                                                    EXP00200
      K = 0                                                             EXP00210
  100 CONTINUE                                                          EXP00220
      IF( TMAX - TT ) 125,150,150                                       EXP00230
  125 CONTINUE                                                          EXP00240
      K = K + 1                                                         EXP00250
      TT = T/(2**K)                                                     EXP00260
      IF( K - 1000 )100,600,600                                         EXP00270
C                                                                       EXP00280
  150 CONTINUE                                                          EXP00290
      SC = TT                                                           EXP00300
      CALL SCALE(A,NA,A,NA,TT)                                          EXP00310
      CALL UNITY(B,NB)                                                  EXP00320
      CALL SCALE(B,NB,DUMMY,NB,TT)                                      EXP00330
      S =  TT/2.                                                        EXP00340
      CALL SCALE(A,NA,DUMMY(L),NA,S)                                    EXP00350
      II = 2                                                            EXP00360
      CALL ADD(DUMMY,NA,DUMMY(L),NA,DUMMY(L),NA)                        EXP00370
      CALL ADD(A,NA,B,NB,DUMMY,NA)                                      EXP00380
      CALL EQUATE(A,NA,C,NC)                                            EXP00390
  200 CONTINUE                                                          EXP00400
      CALL MULT(A,NA,C,NC,B,NB)                                         EXP00410
      S = 1./II                                                         EXP00420
      CALL SCALE(B,NB,C,NC,S)                                           EXP00430
      CALL MAXEL(DUMMY,NA,TOT)                                          ExP00440
      CALL MAXEL(C,NC,DELT)                                             EXP00450
      IF( TOT .GT. 1.0 ) GO TO 300                                      EXP00460
      IF( DELT/TOT .LT. SERCV )  GO TO 400                              EXP00470
      GO TO 350                                                         EXP00480
  300 CONTINUE                                                          EXP00490
      IF( DELT .LT. SERCV )  GO TO 400                                  EXP00500
  350 CONTINUE                                                          EXP00510
      S = TT/(II + 1)                                                   EXP00520
      CALL SCALE(C,NC,B,NB,S)                                           EXP00530
      CALL ADD(B,NB,DUMMY(L),NB,DUMMY(L),NB)                            EXP00540
      CALL ADD(C,NC,DUMMY,NC,DUMMY,NC)                                  EXP00550
      II = II + 1                                                       EXP00560
      GO TO 200                                                         EXP00570
C                                                                       EXP00580
  400 CONTINUE                                                          EXP00590
      CALL EQUATE(DUMMY,NB,B,NB)                                        EXP00600
      IF( K ) 425,500,450                                               EXP00610
  425 CONTINUE                                                          EXP00620
      CALL LNCNT(1)                                                     EXP00630
      PRINT 435                                                         EXP00640
  435 FORMAT('  ERROR IN EXPINT, K IS NEGATIVE')                        EXP00650
      RETURN                                                            EXP00660
C                                                                       EXP00670
  450 CONTINUE                                                          ExP00680
      DO 475 J = 1,K                                                    EXP00690
      TT = 2*TT                                                         EXP00700
      CALL EQUATE(B,NB,DUMMY,NB)                                        EXP00710
      CALL MULT(DUMMY,NA,DUMMY(L),NA,C,NC)                              EXP00720
      CALL ADD(DUMMY(L),NC,C,NC,DUMMY(L),NC)                            EXP00730
      CALL MULT(DUMMY,NB,DUMMY,NB,B,NB)                                 EXP00740
  475 CONTINUE                                                          EXP00750
      T = TT                                                            EXP00760
C                                                                       EXP00770
  500 CONTINUE                                                          EXP00780
      CALL EQUATE(DUMMY(L),NC,C,NC)                                     EXP00790
      S = 1./SC                                                         ExP00800
      CALL SCALE(A,NA,A,NA,S)                                           EXP00810
C                                                                       EXP00820
      IF( IOP .EQ. 0 ) RETURN                                           EXP00830
      CALL LNCNT(5)                                                     EXP00840
      PRINT 550                                                         EXP00850
  550 FORMAT(//,' COMPUTATION OF THE MATRIX EXPONENTIAL  EXP(A T)',/,' AEXP00860
     1ND ITS INTEGRAL OVER  (0,T) BY THE SERIES METHOD ',/)             EXP00870
      CALL PRNT(A,NA,4H A  ,1)                                          EXP00880
      CALL LNCNT(3)                                                     EXP00890
      PRINT 575, T                                                      EXP00900
  575 FORMAT(/,'  T = ',D16.8,/)                                        EXP00910
      CALL  PRNT(B,NB,4HEXPA,1)                                         EXP00920
      CALL PRNT(C,NC,4HINT ,1)                                          EXP00930
      RETURN                                                            EXP00940
C                                                                       EXP00950
  600 CONTINUE                                                          EXP00960
      CALL LNCNT(1)                                                     EXP00970
      PRINT 650                                                         EXP00980
  650 FORMAT( ' ERROR IN EXPINT, K = 1000 ')                            EXP00990
      RETURN                                                            EXP01000
C                                                                       EXP01010
      END                                                               EXP01020
      SUBROUTINE SAMPL(A,NA,B,NB,Q,NQ,R,NR,W,NW,T,IOP,DUMMY)            SAM00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         SAM00020
      DIMENSION A(1),B(1),Q(1),R(1),W(1),DUMMY(1)                       SAM00030
      DIMENSION NA(2),NB(2),NQ(2),NR(2),NW(2),IOP(2),NDUM(2)            SAM00040
      COMMON/CONV/SUMCV,RICTCV,SERCV,MAXSUM                             SAM00050
      IF(  IOP(1) .EQ. 0 ) GO TO 100                                    SAM00060
C                                                                       SAM00070
      IF(  IOP(2) .EQ. 0 ) GO TO 50                                     SAM00080
C                                                                       SAM00090
      CALL LNCNT(5)                                                     SAM00100
      PRINT 25                                                          SAM00110
   25 FORMAT(//,' COMPUTATION OF WEIGHTING MATRICES FOR THE OPTIMAL SAMPSAM00120
     1LED-DATA REGULATOR PROBLEM',//)                                   SAM00130
      CALL PRNT(A,NA,4H A  ,1)                                          SAM00140
      CALL PRNT(B,NB,4H B  ,1)                                          SAM00150
      CALL LNCNT(3)                                                     SAM00160
      PRINT 35                                                          SAM00170
   35 FORMAT(/,' CONTINUOUS PERFORMANCE INDEX WEIGHTING MATRICES',/)    SAM00180
      CALL PRNT(Q,NQ,4H Q  ,1)                                          SAM00190
      CALL PRNT(R,NR,4H R  ,1)                                          SAM00200
      CALL LNCNT(3)                                                     SAM00210
      PRINT 45,T                                                        SAM00220
   45 FORMAT(/,' SAMPLE TIME = ',D16.8,/)                               SAM00230
C                                                                       SAM00240
      GO TO 100                                                         SAM00250
C                                                                       SAM00260
   50 CONTINUE                                                          SAM00270
      CALL LNCNT(8)                                                     SAM00280
      PRINT 75                                                          SAM00290
   75 FORMAT(//,' COMPUTATION OF THE RECONSTRUCTIBILITY GRAMIAN',/,' FORSAM00300
     1 THE (A,H) SYSTEM OVER THE INTERVAL (0,T) ',/,' THE MATRIX Q IS  (SAM00310
     2 H TRANSPOSE ) X H',//)                                           SAM00320
      CALL PRNT(A,NA,4H A  ,1)                                          SAM00330
      CALL PRNT(Q,NQ,4H Q  ,1)                                          SAM00340
      CALL LNCNT(3)                                                     SAM00350
      PRINT 85,T                                                        SAM00360
   85 FORMAT(/,' T = ',D16.8,/)                                         SAM00370
C                                                                       SAM00380
  100 CONTINUE                                                          SAM00390
C                                                                       SAM00400
      N = NA(1)                                                         SAM00410
      L = ( N**2)                                                       SAM00420
      N1 = L + 1                                                        SAM00430
      N2 = N1 + L                                                       SAM00440
      TT  = T                                                           SAM00450
C                                                                       SAM00460
      IOPT = 1                                                          SAM00470
      CALL NORMS(N,N,N,A,IOPT,ANORM)                                    SAM00480
      IOPT = 3                                                          SAM00490
      CALL NORMS(N,N,N,A,IOPT,ROWA)                                     SAM00500
      IF( ANORM .GT. ROWA ) ANORM = ROWA                                SAM00510
C                                                                       SAM00520
      IF( ANORM .LE. 1.E-15 ) GO TO 900                                 SAM00530
C                                                                       SAM00540
      TMAX = 1.0/ANORM                                                  SAM00550
      K = 0                                                             SAM00560
C                                                                       SAM00570
  125 CONTINUE                                                          SAM00580
      IF( TMAX - TT ) 150,150,200                                       SAM00590
  150 CONTINUE                                                          SAM00600
      K = K + 1                                                         SAM00610
      TT = T/( 2**K)                                                    SAM00620
      IF( K - 1000 ) 125,800,800                                        SAM00630
C                                                                       SAM00640
  200 CONTINUE                                                          SAM00650
C                                                                       SAM00660
      I = 0                                                             SAM00670
      SC = TT                                                           SAM00680
      CALL SCALE(A,NA,A,NA,TT)                                          SAM00690
      CALL SCALE(Q,NQ,Q,NQ,TT)                                          SAM00700
      CALL EQUATE(Q,NQ,DUMMY,NQ)                                        SAM00710
C                                                                       SAM00720
      IF( IOP(2) .NE. 0 ) GO TO 500                                     SAM00730
C                                                                       SAM00740
  225 CONTINUE                                                          SAM00750
      II = I + 2                                                        SAM00760
      I = I + 1                                                         SAM00770
      F = 1.0/II                                                        SAM00780
      CALL SCALE(A,NA,DUMMY(N1),NA,F)                                   SAM00790
      CALL MULT(DUMMY,NA,DUMMY(N1),NA,DUMMY(N2),NA)                     SAM00800
      CALL TRANP(DUMMY(N2),NA,DUMMY(N1),NA)                             SAM00810
      CALL ADD(DUMMY(N1),NA,DUMMY(N2),NA,DUMMY,NA)                      SAM00820
C                                                                       SAM00830
      CALL MAXEL(Q,NQ,TOT)                                              SAM00840
      CALL MAXEL(DUMMY,NA,DELT)                                         SAM00850
      IF( TOT .GT. 1.0 ) GO TO 250                                      SAM00860
      IF( DELT/TOT .LT. SERCV )  GO TO 300                              SAM00870
      GO TO 275                                                         SAM00880
  250 CONTINUE                                                          SAM00890
      IF( DELT .LT. SERCV )  GO TO 300                                  SAM00900
  275 CONTINUE                                                          SAM00910
      CALL ADD(Q,NQ,DUMMY,NA,Q,NQ)                                      SAM00920
      GO TO 225                                                         SAM00930
C                                                                       SAM00940
  300 CONTINUE                                                          SAM00950
C                                                                       SAM00960
      IF( K .EQ. 0 ) GO TO 400                                          SAM00970
      N3 = N2 + L                                                       SAM00980
      G = 1.0                                                           SAM00990
      IOPT = 0                                                          SAM01000
      CALL EXPSER(A,NA,DUMMY,NA,G,IOPT,DUMMY(N1))                       SAM01010
C                                                                       SAM01020
  350 CONTINUE                                                          SAM01030
      IF( K .EQ. 0 ) GO TO 400                                          SAM01040
      K = K-1                                                           SAM01050
C                                                                       SAM01060
      CALL TRANP(DUMMY,NA,DUMMY(N1),NA)                                 SAM01070
      CALL MULT(Q,NQ,DUMMY,NA,DUMMY(N2),NA)                             SAM01080
      CALL MULT(DUMMY(N1),NA,DUMMY(N2),NA,DUMMY(N3),NA)                 SAM01090
      CALL ADD(Q,NQ,DUMMY(N3),NA,Q,NQ)                                  SAM01100
      CALL MULT(DUMMY,NA,DUMMY,NA,DUMMY(N1),NA)                         SAM01110
      CALL EQUATE(DUMMY(N1),NA,DUMMY,NA)                                SAM01120
C                                                                       SAM01130
      GO TO 350                                                         SAM01140
C                                                                       SAM01150
  400 CONTINUE                                                          SAM01160
      S =  1.0/SC                                                       SAM01170
      CALL SCALE(A,NA,A,NA,S)                                           SAM01180
C                                                                       SAM01190
      IF( IOP(1) .EQ. 0 ) RETURN                                        SAM01200
      CALL PRNT(Q,NQ,4HGRAM,1)                                          SAM01210
      RETURN                                                            SAM01220
C                                                                       SAM01230
  500 CONTINUE                                                          SAM01240
      CALL SCALE(B,NB,B,NB,TT)                                          SAM01250
      N3 = N2 + L                                                       SAM01260
      N4 = N3 + L                                                       SAM01270
      N5 = N4 + L                                                       SAM01280
      N6 = N5 + L                                                       SAM01290
C                                                                       SAM01300
  525 CONTINUE                                                          SAM01310
      II = I + 2                                                        SAM01320
      I = I + 1                                                         SAM01330
      F = 1.0/II                                                        SAM01340
      CALL SCALE(A,NA,DUMMY(N1),NA,F)                                   SAM01350
      CALL TRANP(DUMMY(N1),NA,DUMMY(N2),NA)                             SAM01360
      CALL MULT(DUMMY,NA,DUMMY(N1),NA,DUMMY(N3),NA)                     SjM01370
      CALL TRANP(DUMMY(N3),NA,DUMMY(N1),NA)                             SjM01380
      CALL MULT(DUMMY,NA,B,NB,DUMMY(N5),NW)                             SAM01390
      CALL ADD(DUMMY(N1),NA,DUMMY(N3),NA,DUMMY,NA)                      SAM01400
      CALL SCALE(DUMMY(N5),NW,DUMMY(N1),NW,F)                           SAM01410
      IF( I .NE. 1 ) GO TO 550                                          SAM01420
      CALL EQUATE(DUMMY(N1),NW,W,NW)                                    SjM01430
      CALL EQUATE(DUMMY(N1),NW,DUMMY(N6),NW)                            SAM01440
      CALL ADD(Q,NQ,DUMMY,NQ,Q,NQ)                                      SAM01450
      GO TO 525                                                         SAM01460
C                                                                       SAM01470
  550 CONTINUE                                                          SAM01480
      CALL MULT(DUMMY(N2),NA,DUMMY(N6),NW,DUMMY(N5),NW)                 SAM01490
      CALL ADD(DUMMY(N5),NW,DUMMY(N1),NW,DUMMY(N1),NW)                  SAM01500
      CALL TRANP(B,NB,DUMMY(N2),NDUM)                                   SAM01510
      CALL SCALE(DUMMY(N2),NDUM,DUMMY(N2),NDUM,F)                       SAM01520
      CALL MULT(DUMMY(N2),NDUM,DUMMY(N6),NW,DUMMY(N3),NR)               SAM01530
      CALL TRANP(DUMMY(N3),NR,DUMMY(N5),NR)                             SAM01540
      CALL ADD(DUMMY(N3),NR,DUMMY(N5),NR,DUMMY(N3),NR)                  SAM01550
      CALL EQUATE(DUMMY(N1),NW,DUMMY(N6),NW)                            SAM01560
      IF(  I .NE. 2 ) GO TO 575                                         SAM01570
      CALL ADD(Q,NQ,DUMMY,NQ,Q,NQ)                                      SAM01580
      CALL ADD(W,NW,DUMMY(N1),NW,W,NW)                                  SAM01590
      CALL EQUATE(DUMMY(N3),NR,DUMMY(N4),NR)                            SAM01600
      GO TO 525                                                         SjM01610
C                                                                       SAM01620
  575 CONTINUE                                                          SAM01630
      CALL MAXEL(Q,NQ,TOT)                                              SAM01640
      CALL MAXEL(DUMMY,NQ,DELT)                                         SAM01650
      IF( TOT .GT. 1.0 )  GO TO 580                                     SAM01660
      IF( DELT/TOT .LT. SERCV )  GO TO 585                              SAM01670
      GO TO 595                                                         SAM01680
C                                                                       SAM01690
  580 CONTINUE                                                          SAM01700
      IF( DELT .LT. SERCV )  GO TO 585                                  SAM01710
      GO TO 595                                                         SAM01720
C                                                                       SAM01730
  585 CONTINUE                                                          SAM01740
      CALL MAXEL(DUMMY(N4),NR,TOT)                                      SAM01750
      CALL MAXEL(DUMMY(N3),NR,DELT)                                     SAM01760
      IF( TOT .GT. 1.0 )  GO TO 590                                     SAM01770
      IF( DELT/TOT .LT. SERCV )  GO TO 600                              SAM01780
      GO TO 595                                                         SAM01790
C                                                                       SAM01800
  590 CONTINUE                                                          SAM01810
      IF( DELT .LT. SERCV )  GO TO 600                                  SAM01820
C                                                                       SAM01830
  595 CONTINUE                                                          SAM01840
      CALL ADD (Q,NQ,DUMMY,NQ,Q,NQ)                                     SAM01850
      CALL ADD(W,NW,DUMMY(N1),NW,W,NW)                                  SAM01860
      CALL ADD(DUMMY(N4),NR,DUMMY(N3),NR,DUMMY(N4),NR)                  SAM01870
      GO TO 525                                                         SAM01880
C                                                                       SAM01890
  600 CONTINUE                                                          SAM01900
      IF( K .EQ. 0 ) GO TO 700                                          SAM01910
      G = 1.0                                                           SAM01920
      IOPT = 0                                                          SAM01930
      CALL EXPINT(A,NA,DUMMY,NA,DUMMY(N1),NA,G,IOPT,DUMMY(N2))          SAM01940
      CALL MULT(DUMMY(N1),NA,B,NB,DUMMY(N2),NB)                         SAM01950
      CALL EQUATE(DUMMY(N2),NB,DUMMY(N1),NB)                            SAM01960
C                                                                       SAM01970
  650 CONTINUE                                                          SAM01980
      IF( K .EQ. 0 ) GO TO 700                                          SAM01990
      K = K - 1                                                         SAM02000
      CALL MULT(Q,NQ,DUMMY,NA,DUMMY(N2),NA)                             SAM02010
      CALL TRANP(DUMMY,NA,DUMMY(N3),NA)                                 SAM02020
      CALL MULT(DUMMY(N3),NA,DUMMY(N2),NA,DUMMY(N5),NA)                 SAM02030
      CALL MULT(Q,NQ,DUMMY(N1),NB,DUMMY(N2),NB)                         SAM02040
      CALL ADD(Q,NQ,DUMMY(N5),NA,Q,NQ)                                  SAM02050
      CALL MULT(DUMMY(N3),NA,DUMMY(N2),NB,DUMMY(N5),NB)                 SAM02060
      CALL MULT(DUMMY(N3),NA,W,NW,DUMMY(N6),NW)                         SAM02070
      CALL ADD(DUMMY(N5),NW,DUMMY(N6),NW,DUMMY(N5),NW)                  SAM02080
      CALL TRANP(DUMMY(N1),NB,DUMMY(N6),NDUM)                           SAM02090
      CALL MULT(DUMMY(N6),NDUM,W,NW,DUMMY(N3),NR)                       SAM02100
      CALL ADD(W,NW,DUMMY(N5),NW,W,NW)                                  SAM02110
      CALL MULT(DUMMY(N6),NDUM,DUMMY(N2),NB,DUMMY(N5),NR)               SAM02120
      CALL ADD(DUMMY(N5),NR,DUMMY(N3),NR,DUMMY(N5),NR)                  SAM02130
      CALL TRANP(DUMMY(N3),NR,DUMMY(N6),NR)                             SAM02140
      CALL ADD(DUMMY(N5),NR,DUMMY(N6),NR,DUMMY(N6),NR)                  SAM02150
      CALL SCALE(DUMMY(N4),NR,DUMMY(N4),NR,2.0)                         SAM02160
      CALL ADD(DUMMY(N6),NR,DUMMY(N4),NR,DUMMY(N4),NR)                  SAM02170
      CALL MULT(DUMMY,NA,DUMMY(N1),NB,DUMMY(N3),NB)                     SAM02180
      CALL ADD(DUMMY(N3),NB,DUMMY(N1),NB,DUMMY(N1),NB)                  SAM02190
      CALL MULT(DUMMY,NA,DUMMY,NA,DUMMY(N3),NA)                         SAM02200
      CALL EQUATE(DUMMY(N3),NA,DUMMY,NA)                                SAM02210
      GO TO 650                                                         SAM02220
C                                                                       SAM02230
  700 CONTINUE                                                          SAM02240
      CALL SCALE(R,NR,R,NR,T)                                           SAM02250
      CALL ADD(R,NR,DUMMY(N4),NR,R,NR)                                  SAM02260
      CALL SCALE(W,NW,W,NW,2.0)                                         SAM02270
      S = 1.0/SC                                                        SAM02280
      CALL SCALE(A,NA,A,NA,S)                                           SAM02290
      CALL SCALE(B,NB,B,NB,S)                                           SAM02300
      IF( IOP(1) .EQ. 0 ) RETURN                                        SAM02310
C                                                                       SAM02320
      CALL LNCNT(3)                                                     SAM02330
      PRINT 750                                                         SAM02340
  750 FORMAT(/,' DISCRETE PERFORMANCE INDEX WEIGHTING MATRICES',/)      SAM02350
      CALL PRNT(Q,NQ,4H Q  ,1)                                          SAM02360
      CALL PRNT(W,NW,4H W  ,1)                                          SAM02370
      CALL PRNT(R,NR,4H R  ,1)                                          SAM02380
      RETURN                                                            SAM02390
C                                                                       SAM02400
  800 CONTINUE                                                          SAM02410
      CALL LNCNT(1)                                                     SAM02420
      PRINT 850                                                         SAM02430
  850 FORMAT(' ERROR IN SAMPL , K = 1000')                              SAM02440
      RETURN                                                            SAM02450
C                                                                       SAM02460
  900 CONTINUE                                                          SAM02470
      CALL SCALE(Q,NQ,Q,NQ,T)                                           SAM02480
      IF( IOP(2) .NE. 0 ) GO TO 925                                     SAM02490
      IF( IOP(1) .NE. 0 ) CALL PRNT(Q,NQ,4HGRAM,1)                      SAM02500
      RETURN                                                            SAM02510
C                                                                       SAM02520
  925 CONTINUE                                                          SAM02530
      CALL MULT(Q,NQ,B,NB,W,NW)                                         SAM02540
      CALL SCALE(W,NW,W,NW,T)                                           SAM02550
      CALL TRANP(B,NB,DUMMY,NDUM)                                       SAM02560
      CALL MULT(DUMMY,NDUM,W,NW,DUMMY(N1),NR)                           SAM02570
      TT = T/3.                                                         SjM02580
      CALL SCALE(DUMMY(N1),NR,DUMMY,NR,TT)                              SAM02590
      CALL SCALE(R,NR,R,NR,T)                                           SAM02600
      CALL ADD(R,NR,DUMMY,NR,R,NR)                                      SAM02610
      IF( IOP(1) .EQ. 0 ) RETURN                                        SAM02620
      CALL LNCNT(3)                                                     SAM02630
      PRINT 750                                                         SAM02640
      CALL PRNT(Q,NQ,4H Q  ,1)                                          SAM02650
      CALL PRNT(W,NW,4H W  ,1)                                          SAM02660
      CALL PRNT(R,NR,4H R  ,1)                                          SAM02670
      RETURN                                                            SAM02680
C                                                                       SAM02690
      END                                                               SAM02700
      SUBROUTINE PREFIL(A,NA,B,NB,Q,NQ,W,NW,R,NR,F,NF,IOP,DUMMY)        PRE00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         PRE00020
      DIMENSION A(1),B(1),Q(1),W(1),R(1),F(1),DUMMY(1)                  PRE00030
      DIMENSION NA(2),NB(2),NQ(2),NW(2),NR(2),NF(2),IOP(3)              PRE00040
      IF( IOP(1) .EQ. 0 ) GO TO 100                                     PRE00050
      CALL LNCNT(5)                                                     PRE00060
      PRINT 25                                                          PRE00070
   25 FORMAT(//,' PROGRAM TO COMPUTE PREFILTER GAIN F TO ELEMINATE  CROSPRE00080
     1S-PRODUCT TERM ',/,' IN QUADRATIC PERFORMANCE INDEX ',/)          PRE00090
      IF( IOP(3) .EQ. 0 ) GO TO 50                                      PRE00100
      CALL PRNT(A,NA,4H A  ,1)                                          PRE00110
      CALL PRNT(B,NB,4H B  ,1)                                          PrE00120
   50 CONTINUE                                                          PRE00130
      CALL PRNT(Q,NQ,4H Q  ,1)                                          PRE00140
      CALL PRNT(W,NW,4H W  ,1)                                          PRE00150
      CALL PRNT(R,NR,4H R  ,1)                                          PRE00160
C                                                                       PRE00170
  100 CONTINUE                                                          PRE00180
      CALL TRANP(W,NW,F,NF)                                             PRE00190
      CALL SCALE(F,NF,F,NF,0.5)                                         PRE00200
      CALL EQUATE(R,NR,DUMMY,NR)                                        PRE00210
      IOPT=0                                                            PRE00220
      IFAC=0                                                            PRE00230
      N1 = NR(1)**2 + 1                                                 PRE00240
      M = NR(1)                                                         PRE00250
      CALL SYMPDS(M,M,DUMMY,NF(2),F,IOPT,IFAC,DETERM,ISCALE,DUMMY(N1),IEPRE00260
     1RR)                                                               PRE00270
      IF( IERR .EQ. 0 ) GO TO 200                                       PRE00280
      CALL LNCNT(4)                                                     PRE00290
      PRINT 150                                                         PRE00300
  150 FORMAT(//,' IN PREFIL, THE MATRIX R IS NOT SYMMETRIC POSITIVE DEFIPRE00310
     1NITE',/)                                                          PRE00320
      RETURN                                                            PRE00330
C                                                                       PRE00340
  200 CONTINUE                                                          PRE00350
      IF( IOP(2) .EQ. 0 ) GO TO 300                                     PRE00360
      CALL MULT(W,NW,F,NF,DUMMY,NQ)                                     PRE00370
      CALL SCALE(DUMMY,NQ,DUMMY,NQ,0.5)                                 PRE00380
      CALL SUBT(Q,NQ,DUMMY,NQ,Q,NQ)                                     PRE00390
C                                                                       PRE00400
  300 CONTINUE                                                          PRE00410
      IF( IOP(3) .EQ. 0 ) GO TO 400                                     PRE00420
      CALL MULT(B,NB,F,NF,DUMMY,NA)                                     PRE00430
      CALL SUBT(A,NA,DUMMY,NA,A,NA)                                     PRE00440
C                                                                       PRE00450
  400 CONTINUE                                                          PRE00460
      IF( IOP(1) .EQ. 0 ) RETURN                                        PRE00470
      CALL PRNT(F,NF,4H F  ,1)                                          PRE00480
      IF( IOP(2) .EQ. 0 ) GO TO 500                                     PRE00490
      CALL LNCNT(3)                                                     PRE00500
      PRINT 450                                                         PRE00510
  450 FORMAT(/, ' MATRIX  Q - (W/2)F ',/)                               PRE00520
      CALL PRNT(Q,NQ,4HNEWQ,1)                                          PRE00530
C                                                                       PRE00540
  500 CONTINUE                                                          PRE00550
      IF( IOP(3) .EQ. 0 ) RETURN                                        PRE00560
      CALL PRNT(A,NA,4HNEWA,1)                                          PRE00570
      RETURN                                                            PRE00580
      END                                                               PRE00590
      SUBROUTINE CSTAB(A,NA,B,NB,F,NF,IOP,SCLE,DUMMY)                   CST00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         CST00020
      DIMENSION A(1),B(1),F(1),DUMMY(1)                                 CST00030
      DIMENSION NA(2),NB(2),NF(2),IOP(3),NDUM(2)                        CST00040
      DIMENSION IOPT(2)                                                 CST00050
      LOGICAL SYM                                                       CST00060
      COMMON/TOL/EPSAM,EPSBM,IACM                                       CST00070
      N = NA(1)**2                                                      CST00080
      N1=N+1                                                            CST00090
C                                                                       CST00100
      IF(IOP(2) .EQ. 0 ) GO TO 100                                      CST00110
      CALL EQUATE(A,NA,DUMMY,NA)                                        CST00120
      N2=N1+NA(1)                                                       CST00130
      N3=N2+NA(1)                                                       CST00140
      ISV =0                                                            CST00150
      ILV =0                                                            CST00160
      CALL EIGEN(NA(1),NA(1),DUMMY,DUMMY(N1),DUMMY(N2),ISV,ILV,V,DUMMY(NCST00170
     13),IERR)                                                          CST00180
C                                                                       CST00190
      M=NA(1)                                                           CST00200
      IF(IERR .EQ. 0) GO TO 50                                          CST00210
      CALL LNCNT(3)                                                     CST00220
      PRINT 25,IERR                                                     CST00230
   25 FORMAT(//,' IN CSTAB, THE SUBROUTINE EIGEN FAILED TO DETERMINE THECST00240
     1 ',I4,' EIGENVALUE FOR THE MATRIX A  AFTER 30 ITERATIONS')        CST00250
      IERR=1                                                            CST00260
      CALL NORMS(M,M,M,A,IERR,BETA)                                     CST00270
      BETA=2.*BETA                                                      CST00280
      GO TO 200                                                         CST00290
   50 CONTINUE                                                          CST00300
C                                                                       CST00310
      BETA = 0.0                                                        CST00320
      DO 75 I = 1,M                                                     CST00330
      J = N1 + I - 1                                                    CST00340
      BETA1 = DABS(DUMMY(J))                                            CST00350
      IF(BETA1 .GT. BETA)  BETA = BETA1                                 CST00360
   75 CONTINUE                                                          CST00370
      BETA = SCLE*(BETA + .001)                                         CST00380
      GO TO 200                                                         CST00390
C                                                                       CST00400
  100 CONTINUE                                                          CST00410
      BETA = SCLE                                                       CST00420
  200 CONTINUE                                                          CST00430
C                                                                       CST00440
      CALL TRANP(B,NB,DUMMY,NDUM)                                       CST00450
      CALL MULT(B,NB,DUMMY,NDUM,DUMMY(N1),NA)                           CST00460
      CALL SCALE(DUMMY(N1),NA,DUMMY,NA,-2.0)                            CST00470
      CALL SCALE(A,NA,DUMMY(N1),NA,-1.0)                                CST00480
      J = -NA(1)                                                        CST00490
      NAX = NA(1)                                                       CST00500
      DO 225 I=1,NAX                                                    CST00510
      J = J+NAX+1                                                       CST00520
      K = N1+J-1                                                        CST00530
      DUMMY(K)=DUMMY(K)-BETA                                            CST00540
  225 CONTINUE                                                          CST00550
      N2 = N1 + N                                                       CST00560
      SYM = .TRUE.                                                      CST00570
      IOPT(1)=0                                                         CST00580
C                                                                       CST00590
      IF( IOP(3) .NE. 0 )  GO TO 300                                    CST00600
      EPSA=EPSAM                                                        CST00610
      CALL BARSTW(DUMMY(N1),NA,A,NA,DUMMY,NA,IOPT,SYM,EPSA,EPSA,DUMMY(N2CST00620
     1))                                                                CST00630
      GO TO 350                                                         CST00640
  300 CONTINUE                                                          CST00650
      IOPT(2) = 1                                                       CST00660
      CALL BILIN(DUMMY(N1),NA,A,NA,DUMMY,NA,IOPT,ASCLE,SYM,DUMMY(N2))   CST00670
  350 CONTINUE                                                          CST00680
C                                                                       CST00690
      CALL EQUATE(B,NB,DUMMY(N1),NB)                                    CST00700
      IOPT(1) = 3                                                       CST00710
      IAC =IACM                                                         CST00720
      N3 = N2 + NA(1)                                                   CST00730
      CALL SNVDEC(IOPT,NA(1),NA(1),NA(1),NA(1),DUMMY,NB(2),DUMMY(N1),IACCST00740
     1,ZTEST,DUMMY(N2),DUMMY(N3),IRANK,APLUS,IERR)                      CST00750
      IF(IERR .EQ. 0 ) GO TO 400                                        CST00760
      CALL LNCNT(5)                                                     CST00770
      IF(IERR .GT. 0 ) PRINT 360,IERR                                   CST00780
      IF(IERR .EQ. -1) PRINT 370,ZTEST,IRANK                            CST00790
  360 FORMAT(//,' IN CSTAB, SNVDEC HAS FAILED TO CONVERGE TO THE ',I4,' CST00800
     1SINGULARVALUE AFTER 30 ITERATIONS',//)                            CST00810
  370 FORMAT(//,' IN CSTAB, THE MATRIX SUBMITTED TO SNVDEC USING ZTEST =CST00820
     1 ',D16.8,' IS CLOSE TO A  MATRIX OF LOWER  RANK ',/,' IF THE ACCURCST00830
     2ACY IAC IS REDUCED THE RANK MAY ALSO BE REDUCED',/,' CURRENT RANK CST00840
     3 =',I4)                                                           CST00850
      IF( IERR .GT. 0 ) RETURN                                          CST00860
      NDUM(1) = NA(1)                                                   CST00870
      NDUM(2) =1                                                        CST00880
      CALL PRNT(DUMMY(N2),NDUM,4HSGVL,1)                                CST00890
  400 CONTINUE                                                          CST00900
C                                                                       CST00910
      CALL TRANP(DUMMY(N1),NB,F,NF)                                     CST00920
      IF ( IOP(1) .EQ. 0 )   RETURN                                     CST00930
      CALL LNCNT(4)                                                     CST00940
      PRINT 500                                                         CST00950
  500 FORMAT(//,' COMPUTATION OF F MATRIX SUCH THAT A-BF IS ASYMPTOTICALCST00960
     1LY STABLE IN THE CONTINUOUS SENSE ',/)                            CST00970
      CALL PRNT(A,NA,4H A  ,1)                                          CST00980
      CALL LNCNT(4)                                                     CST00990
      PRINT 550,BETA                                                    CST01000
  550 FORMAT(//,' BETA = ',D16.8,/)                                     CST01010
      CALL PRNT(B,NB,4H B  ,1)                                          CST01020
      CALL PRNT(F,NF,4H F  ,1)                                          CST01030
      CALL MULT(B,NB,F,NF,DUMMY,NA)                                     CST01040
      CALL SUBT(A,NA,DUMMY,NA,DUMMY,NA)                                 CST01050
      CALL PRNT(DUMMY,NA,4HA-BF,1)                                      CST01060
      N2 = N1+NA(1)                                                     CST01070
      N3 = N2+NA(1)                                                     CST01080
      ISV = 0                                                           CST01090
      ILV = 0                                                           CST01100
      CALL EIGEN(NA(1),NA(1),DUMMY,DUMMY(N1),DUMMY(N2),ISV,ILV,V,DUMMY(NCST01110
     13),IERR)                                                          CST01120
      M = NA(1)                                                         CST01130
      IF( IERR .EQ. 0 ) GO TO 600                                       CST01140
      M = NA(1)-IERR                                                    CST01150
      CALL LNCNT(3)                                                     CST01160
      PRINT 25,IERR                                                     CST01170
  600 CONTINUE                                                          CST01180
      CALL LNCNT(4)                                                     CST01190
      PRINT 650                                                         CST01200
  650 FORMAT(//,' EIGENVALUES OF A-BF',/)                               CST01210
  675 FORMAT(10X,2D16.8)                                                CST01220
      CALL LNCNT(M)                                                     CST01230
      DO 700 I=1,M                                                      CST01240
      J = N1+I-1                                                        CST01250
      K = N2+I-1                                                        CST01260
      PRINT 675,DUMMY(J),DUMMY(K)                                       CST01270
  700 CONTINUE                                                          CST01280
C                                                                       CST01290
      RETURN                                                            CST01300
      END                                                               CST01310
      SUBROUTINE DSTAB(A,NA,B,NB,F,NF,SING,IOP,SCLE,DUMMY)              DST00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         DST00020
      DIMENSION A(1),B(1),F(1),DUMMY(1)                                 DST00030
      DIMENSION NA(2),NB(2),NF(2),NDUM(2),IOP(2),IOPT(3),NDUM1(2)       DST00040
      LOGICAL SING,SYM                                                  DST00050
      COMMON/TOL/EPSAM,EPSBM,IACM                                       DST00060
      N = NA(1)**2                                                      DST00070
      N1 = N + 1                                                        DST00080
      N2 = N1 + N                                                       DST00090
      IF( .NOT. SING ) GO TO 100                                        DST00100
      IOPT(1)=IOP(1)                                                    DST00110
      IOPT(2) = 1                                                       DST00120
      IOPT(3) = 0                                                       DST00130
      CSCLE=1.05                                                        DST00140
      CALL CSTAB(A,NA,B,NB,F,NF,IOPT,CSCLE,DUMMY)                       DST00150
      CALL MULT(B,NB,F,NF,DUMMY,NA)                                     DST00160
      CALL SUBT(A,NA,DUMMY,NA,DUMMY,NA)                                 DST00170
      CALL EQUATE(DUMMY,NA,DUMMY(N1),NA)                                DST00180
      GO TO 200                                                         DST00190
C                                                                       DST00200
  100 CONTINUE                                                          DST00210
      CALL EQUATE(A,NA,DUMMY,NA)                                        DST00220
      CALL EQUATE(A,NA,DUMMY(N1),NA)                                    DST00230
C                                                                       DST00240
  200 CONTINUE                                                          DST00250
      IF( IOP(2) .EQ. 0 ) GO TO 300                                     DST00260
      N3 = N2 + NA(1)                                                   DST00270
      N4 = N3 + NA(1)                                                   DST00280
      ISV = 0                                                           DST00290
      CALL EIGEN(NA(1),NA(1),DUMMY(N1),DUMMY(N2),DUMMY(N3),ISV,ISV,V,DUMDST00300
     1MY(N4),IERR)                                                      DST00310
      CALL EQUATE(DUMMY,NA,DUMMY(N1),NA)                                DST00320
      M = NA(1)                                                         DST00330
      IF( IERR .EQ. 0 ) GO TO 250                                       DST00340
      CALL LNCNT(3)                                                     DST00350
      PRINT 225                                                         DST00360
  225 FORMAT(//,' IN DSTAB, THE PROGRAM EIGEN FAILED TO DETERMINE THE ',DST00370
     1I5,' EIGENVALUE FOR THE A-BF MATRIX AFTER 30 ITERATIONS')         DST00380
      CALL PRNT(DUMMY,NA,4HA-BG,1)                                      DST00390
      IF( SING ) CALL PRNT(F,NF,4H G  ,1)                               DST00400
      RETURN                                                            DST00410
C                                                                       DST00420
  250 CONTINUE                                                          DST00430
      ALPHA = 1.0                                                       DST00440
      DO 275 I =1,M                                                     DST00450
      I1 = N2 + I -1                                                    DST00460
      I2 = N3 + I -1                                                    DST00470
      ALPHA1 = DSQRT(DUMMY(I1)**2 + DUMMY(I2)**2)                       DST00480
      IF( ALPHA1 .LT. ALPHA .AND. ALPHA1 .NE. 0 ) ALPHA = ALPHA1        DST00490
  275 CONTINUE                                                          DST00500
      ALPHA = SCLE*ALPHA                                                DST00510
      GO TO 400                                                         DST00520
C                                                                       DST00530
  300 CONTINUE                                                          DST00540
      ALPHA = SCLE                                                      DST00550
C                                                                       DST00560
  400 CONTINUE                                                          DST00570
      J = -NA(1)                                                        DST00580
      NAX = NA(1)                                                       DST00590
      DO 425 I = 1,NAX                                                  DST00600
      J = J + NAX + 1                                                   DST00610
      K = N1 + J -1                                                     DST00620
      DUMMY(K) = DUMMY(J) - ALPHA                                       DST00630
      DUMMY(J) = DUMMY(J) + ALPHA                                       DST00640
  425 CONTINUE                                                          DST00650
      CALL EQUATE(B,NB,DUMMY(N2),NB)                                    DST00660
      N3 = N2 + NA(1)*NB(2)                                             DST00670
      NRHS = NA(1)+NB(2)                                                DST00680
      N4 = N3 + NA(1)                                                   DST00690
      IFAC = 0                                                          DST00700
      CALL GELIM(NA(1),NA(1),DUMMY,NRHS,DUMMY(N1),DUMMY(N3),IFAC,DUMMY(NDST00710
     14),IERR)                                                          DST00720
      IF( IERR .EQ. 0 ) GO TO 500                                       DST00730
      CALL LNCNT(3)                                                     DST00740
      IF( .NOT. SING ) GO TO 445                                        DST00750
      PRINT 435                                                         DST00760
  435 FORMAT(//,' IN DSTAB, GELIM HAS FOUND THE MATRIX ( A-BG) + (ALPHA)DST00770
     1I SINGULAR ')                                                     DST00780
      CALL PRNT(A,NA,4H A  ,1)                                          DST00790
      CALL PRNT(F,NF,4H G  ,1)                                          DST00800
      GO TO 465                                                         DST00810
  445 CONTINUE                                                          DST00820
      CALL LNCNT(3)                                                     DST00830
      PRINT 455                                                         DST00840
  455 FORMAT(//,' IN DSTAB, GELIM HAS FOUND THE MATRIX A + (ALPHA)I SINGDST00850
     1ULAR ')                                                           DST00860
      CALL PRNT(A,NA,4H A  ,1)                                          DST00870
  465 CONTINUE                                                          DST00880
      CALL LNCNT(3)                                                     DST00890
      PRINT 475,ALPHA                                                   DST00900
  475 FORMAT(//,' ALPHA = ',D16.8)                                      DST00910
      RETURN                                                            DST00920
C                                                                       DST00930
  500 CONTINUE                                                          DST00940
      CALL EQUATE(DUMMY(N1),NA,DUMMY,NA)                                DST00950
      CALL TRANP(DUMMY(N2),NB,DUMMY(N1),NDUM)                           DST00960
      N3 = N2 + N                                                       DST00970
      CALL MULT(DUMMY(N2),NB,DUMMY(N1),NDUM,DUMMY(N3),NA)               DST00980
      CALL SCALE(DUMMY(N3),NA,DUMMY(N1),NA,4.0)                         DST00990
      SYM = .TRUE.                                                      DST01000
      IOPT(1) = 0                                                       DST01010
      EPSA=EPSAM                                                        DST01020
      CALL BARSTW(DUMMY,NA,B,NB,DUMMY(N1),NA,IOPT,SYM,EPSA,EPSA,DUMMY(N2DST01030
     1))                                                                DST01040
      CALL EQUATE(DUMMY(N1),NA,DUMMY,NA)                                DST01050
      CALL TRANP(B,NB,DUMMY(N1),NDUM)                                   DST01060
      CALL MULT(B,NB,DUMMY(N1),NDUM,DUMMY(N2),NA)                       DST01070
      CALL ADD(DUMMY,NA,DUMMY(N2),NA,DUMMY,NA)                          DST01080
      CALL EQUATE(A,NA,DUMMY(N1),NA)                                    DST01090
      IF( .NOT. SING ) GO TO 600                                        DST01100
      CALL MULT(B,NB,F,NF,DUMMY(N1),NA)                                 DST01110
      CALL SUBT(A,NA,DUMMY(N1),NA,DUMMY(N1),NA)                         DST01120
C                                                                       DST01130
  600 CONTINUE                                                          DST01140
      IOPT(1) = 3                                                       DST01150
      M = NA(1)                                                         DST01160
      IAC=IACM                                                          DST01170
      CALL SNVDEC(IOPT,M,M,M,M,DUMMY,M,DUMMY(N1),IAC,ZTEST,DUMMY(N2),DUMDST01180
     1MY(N3),IRANK,APLUS,IERR)                                          DST01190
      IF( IERR  .EQ. 0 ) GO TO 700                                      DST01200
      CALL LNCNT(5)                                                     DST01210
      IF( IERR .GT. 0 ) PRINT 625,IERR                                  DST01220
      IF( IERR .EQ. -1) PRINT 650,ZTEST,IRANK                           DST01230
  625 FORMAT(//,' IN DSTAB, SNVDEC HAS FAILED TO CONVERGE TO THE ',I5,' DST01240
     1SINGULAR VALUE AFTER 30 ITERATIONS')                              DST01250
  650 FORMAT(//,' IN DSTAB, THE MATRIX SUBMITTED TO SNVDEC, USING ZTEST DST01260
     1= ',D16.8,' , IS CLOSE TO A MATRIX OF LOWER RANK',/,' IF THE ACCURDST01270
     2ACY IAC IS REDUCED THE RANK MAY ALSO BE REDUCED',/,' CURRENT RANK DST01280
     3 =',I4)                                                           DST01290
      IF( IERR  .GT. 0 ) RETURN                                         DST01300
      NDUM(1)= NA(1)                                                    DST01310
      NDUM(2)= 1                                                        DST01320
      CALL PRNT(DUMMY(N2),NDUM,4HSGVL,1)                                DST01330
C                                                                       DST01340
  700 CONTINUE                                                          DST01350
      CALL TRANP(B,NB,DUMMY(N2),NDUM)                                   DST01360
      CALL MULT(DUMMY(N2),NDUM,DUMMY(N1),NA,DUMMY,NF)                   DST01370
      IF( .NOT. SING ) GO TO 800                                        DST01380
      CALL ADD(F,NF,DUMMY,NF,F,NF)                                      DST01390
      GO TO 900                                                         DST01400
C                                                                       DST01410
  800 CONTINUE                                                          DST01420
      CALL EQUATE(DUMMY,NF,F,NF)                                        DST01430
C                                                                       DST01440
  900 CONTINUE                                                          DST01450
      IF( IOP(1) .EQ. 0 ) RETURN                                        DST01460
      CALL LNCNT(4)                                                     DST01470
      PRINT 1000                                                        DST01480
 1000 FORMAT(//,' COMPUTATION OF F SUCH THAT A-BF IS ASYMPTOTICALLY STABDST01490
     1LE IN THE DISCRETE SENSE',/)                                      DST01500
      CALL PRNT(A,NA,4H A  ,1)                                          DST01510
      CALL PRNT(B,NB,4H B  ,1)                                          DST01520
      CALL LNCNT(4)                                                     DST01530
      PRINT 1100,ALPHA                                                  DST01540
 1100 FORMAT(//,' ALPHA = ',D16.8,/)                                    DST01550
      CALL PRNT(F,NF,4H F  ,1)                                          DST01560
      CALL MULT(B,NB,F,NF,DUMMY,NA)                                     DST01570
      CALL SUBT(A,NA,DUMMY,NA,DUMMY,NA)                                 DST01580
      CALL PRNT(DUMMY,NA,4HA-BF,1)                                      DST01590
      CALL LNCNT(3)                                                     DST01600
      PRINT 1200                                                        DST01610
 1200 FORMAT(//,' EIGENVALUES OF A-BF')                                 DST01620
      NDUM(1) = NA(1)                                                   DST01630
      NDUM(2) = 1                                                       DST01640
      N2 = N1 + NA(1)                                                   DST01650
      N3 = N2 + NA(1)                                                   DST01660
      ISV = 0                                                           DST01670
      CALL EIGEN(NA(1),NA(1),DUMMY,DUMMY(N1),DUMMY(N2),ISV,ISV,V,DUMMY(NDST01680
     13),IERR)                                                          DST01690
      IF( IERR .EQ. 0 ) GO TO 1300                                      DST01700
      CALL LNCNT(3)                                                     DST01710
      PRINT 1250                                                        DST01720
 1250 FORMAT(//,' IN DSTAB, THE PROGRAM EIGEN FAILED TO DETERMINE THE ',DST01730
     1I5,' EIGENVALUE FOR THE A-BF MATRIX AFTER 30 ITERATIONS')         DST01740
      NDUM(1)=NA(1)-IERR                                                DST01750
C                                                                       DST01760
 1300 CONTINUE                                                          DST01770
      CALL JUXTC(DUMMY(N1),NDUM,DUMMY(N2),NDUM,DUMMY,NDUM1)             DST01780
      CALL PRNT(DUMMY,NDUM1,4HEIGN,1)                                   DST01790
      CALL LNCNT(4)                                                     DST01800
      PRINT 1400                                                        DST01810
 1400 FORMAT(//,' MODULI OF EIGENVALUES OF A-BF',/)                     DST01820
      M =NDUM(1)                                                        DST01830
      DO 1500 I = 1,M                                                   DST01840
      J = N1 + I - 1                                                    DST01850
      K = N2 + I - 1                                                    DST01860
      DUMMY(I)=DSQRT(DUMMY(J)**2 + DUMMY(K)**2)                         DST01870
 1500 CONTINUE                                                          DST01880
      CALL PRNT(DUMMY,NDUM,4HMOD ,1)                                    DST01890
C                                                                       DST01900
      RETURN                                                            DST01910
      END                                                               DST01920
      SUBROUTINE DISREG(A,NA,B,NB,H,NH,Q,NQ,R,NR,F,NF,P,NP,IOP,IDENT,DU DIS00010
     1MMY)                                                              DIS00020
      IMPLICIT REAL*8 (A-H,O-Z)                                         DIS00030
      DIMENSION A(1),B(1),Q(1),R(1),F(1),P(1),DUMMY(1)                  DIS00040
      DIMENSION NA(2),NB(2),NQ(2),NR(2),NF(2),NP(2)                     DIS00050
      DIMENSION IOP(3)                                                  DIS00060
      DIMENSION H(1),NH(2),NDUM(2)                                      DIS00070
      LOGICAL  IDENT                                                    DIS00080
      COMMON/TOL/EPSAM,EPSBM,IACM                                       DIS00090
      COMMON/CONV/SUMCV,RICTCV,SERCV,MAXSUM                             DIS00100
      N = NA(1)**2                                                      DIS00110
      N1= N +1                                                          DIS00120
      N2= N1+N                                                          DIS00130
      N3= N2+N                                                          DIS00140
C                                                                       DIS00150
      KSS = 0                                                           DIS00160
      I=IOP(3)                                                          DIS00170
C                                                                       DIS00180
      IF(IOP(1) .EQ. 0)  GO TO 85                                       DIS00190
      CALL LNCNT(5)                                                     DIS00200
      PRINT 25                                                          DIS00210
   25 FORMAT(//,' PROGRAM TO SOLVE THE TIME-INVARIANT FINITE-DURATION OPDIS00220
     1TIMAL',/,' DIGITAL REGULATOR PROBLEM WITH NOISE-FREE MEASUREMENTS'DIS00230
     2,/)                                                               DIS00240
      CALL PRNT(A,NA,4H A  ,1)                                          DIS00250
      CALL PRNT(B,NB,4H B  ,1)                                          DIS00260
      CALL PRNT(Q,NQ,4H Q  ,1)                                          DIS00270
      IF( .NOT. IDENT )  GO TO 45                                       DIS00280
      CALL LNCNT(3)                                                     DIS00290
      PRINT 35                                                          DIS00300
   35 FORMAT(/,' H IS AN IDENTITY MATRIX',/)                            DIS00310
      GO TO 65                                                          DIS00320
   45 CONTINUE                                                          DIS00330
      CALL PRNT(H,NH,4H H  ,1)                                          DIS00340
      CALL MULT(Q,NQ,H,NH,DUMMY,NH)                                     DIS00350
      CALL TRANP(H,NH,DUMMY(N1),NF)                                     DIS00360
      CALL MULT(DUMMY(N1),NF,DUMMY,NH,Q,NQ)                             DIS00370
      CALL LNCNT(3)                                                     DIS00380
      PRINT 55                                                          DIS00390
   55 FORMAT(/,' MATRIX ( H TRANSPOSE )QH',/)                           DIS00400
      CALL PRNT(Q,NQ,4HHTQH,1)                                          DIS00410
   65 CONTINUE                                                          DIS00420
      CALL PRNT(R,NR,4H R  ,1)                                          DIS00430
      CALL LNCNT(4)                                                     DIS00440
      PRINT 75                                                          DIS00450
   75 FORMAT(//,' WEIGHTING ON TERMINAL VALUE OF STATE VECTOR',/)       DIS00460
      CALL PRNT(P,NP,4H P  ,1)                                          DIS00470
C                                                                       DIS00480
   85 CONTINUE                                                          DIS00490
      IF((IOP(1) .NE. 0)  .OR. IDENT)  GO TO 100                        DIS00500
      CALL MULT(Q,NQ,H,NH,DUMMY,NH)                                     DIS00510
      CALL TRANP(H,NH,DUMMY(N1),NF)                                     DIS00520
      CALL MULT(DUMMY(N1),NF,DUMMY,NH,Q,NQ)                             DIS00530
C                                                                       DIS00540
  100 CONTINUE                                                          DIS00550
      I=I-1                                                             DIS00560
      CALL EQUATE(P,NP,DUMMY,NP)                                        DIS00570
      CALL MULT(P,NP,A,NA,DUMMY(N1),NA)                                 DIS00580
      CALL TRANP(B,NB,DUMMY(N2),NF)                                     DIS00590
      CALL MULT(DUMMY(N2),NF,DUMMY(N1),NA,F,NF)                         DIS00600
      CALL MULT(P,NP,B,NB,DUMMY(N1),NB)                                 DIS00610
      CALL MULT(DUMMY(N2),NF,DUMMY(N1),NB,DUMMY(N3),NR)                 DIS00620
      CALL ADD(R,NR,DUMMY(N3),NR,DUMMY(N1),NR)                          DIS00630
      IOPT = 3                                                          DIS00640
      IAC=IACM                                                          DIS00650
      MF = NR(1)                                                        DIS00660
      CALL SNVDEC(IOPT,MF,MF,MF,MF,DUMMY(N1),NF(2),F,IAC,ZTEST,DUMMY(N2)DIS00670
     1,DUMMY(N3),IRANK,APLUS,IERR)                                      DIS00680
      IF( IERR .EQ.0) GO TO 300                                         DIS00690
      CALL LNCNT(5)                                                     DIS00700
      IF(IERR .GT. 0) PRINT 200,IERR                                    DIS00710
      IF(IERR  .EQ. -1) PRINT 250,ZTEST,IRANK                           DIS00720
  200 FORMAT(//,' IN DISREG, SNVDEC HAS FAILED TO CONVERGE TO THE ',I4, DIS00730
     1'SINGULARVALUE AFTER 30 ITERATIONS',//)                           DIS00740
  250 FORMAT(//,' IN DISREG, THE MATRIX SUBMITTED TO SNVDEC USING ZTEST DIS00750
     1=',D16.8,' IS CLOSE TO A MATRIX OF LOWER RANK',/,'IF  THE ACCURACYDIS00760
     2 IAC IS REDUCED THE RANK MAY ALSO BE REDUCED',/,' CURRENT RANK = 'DIS00770
     3 ,I4)                                                             DIS00780
      IF( IERR .GT. 0 ) RETURN                                          DIS00790
      NDUM(1) = NA(1)                                                   DIS00800
      NDUM(2) =  1                                                      DIS00810
      CALL PRNT(DUMMY(N2),NDUM,4HSGVL,1)                                DIS00820
C                                                                       DIS00830
  300 CONTINUE                                                          DIS00840
      CALL MULT(R,NR,F,NF,DUMMY(N1),NF)                                 DIS00850
      CALL TRANP(F,NF,DUMMY(N2),NB)                                     DIS00860
      CALL MULT(DUMMY(N2),NB,DUMMY(N1),NF,P,NP)                         DIS00870
      CALL ADD(Q,NQ,P,NP,P,NP)                                          DIS00880
      CALL MULT(B,NB,F,NF,DUMMY(N1),NA)                                 DIS00890
      CALL SUBT(A,NA,DUMMY(N1),NA,DUMMY(N1),NA)                         DIS00900
      CALL MULT(DUMMY,NA,DUMMY(N1),NA,DUMMY(N2),NA)                     DIS00910
      CALL TRANP(DUMMY(N1),NA,DUMMY(N3),NA)                             DIS00920
      CALL MULT(DUMMY(N3),NA,DUMMY(N2),NA,DUMMY(N1),NA)                 DIS00930
      CALL ADD(P,NP,DUMMY(N1),NA,P,NP)                                  DIS00940
C                                                                       DIS00950
      IF( IOP(2) .EQ. 0 )  GO TO 400                                    DIS00960
      CALL LNCNT(5)                                                     DIS00970
      PRINT 350,I                                                       DIS00980
  350 FORMAT(///,' STAGE ',I5,/)                                        DIS00990
      CALL PRNT(F,NF,4H F  ,1)                                          DIS01000
      CALL PRNT(P,NP,4H P  ,1)                                          DIS01010
C                                                                       DIS01020
  400 CONTINUE                                                          DIS01030
      IF( I .EQ. 0 )  GO TO 600                                         DIS01040
      CALL MAXEL(DUMMY,NP,ANORM1)                                       DIS01050
      CALL SUBT(DUMMY,NP,P,NP,DUMMY(N2),NP)                             DIS01060
      CALL MAXEL(DUMMY(N2),NP,ANORM2)                                   DIS01070
      IF( ANORM1 .NE. 0.0 )  GO TO 500                                  DIS01080
      GO TO 100                                                         DIS01090
C                                                                       DIS01100
  500 CONTINUE                                                          DIS01110
      IF(ANORM1 .GT. 1.0 ) GO TO 550                                    DIS01120
      IF( ANORM2/ANORM1 .LT. RICTCV ) KSS = 1                           DIS01130
      GO TO 575                                                         DIS01140
  550 CONTINUE                                                          DIS01150
      IF( ANORM2 .LT. RICTCV ) KSS=1                                    DIS01160
  575 CONTINUE                                                          DIS01170
      IF( KSS .EQ. 1) GO TO 600                                         DIS01180
      GO TO 100                                                         DIS01190
C                                                                       DIS01200
  600 CONTINUE                                                          DIS01210
      K = IOP(1) + IOP(2)                                               DIS01220
      IF( K .EQ. 0 ) RETURN                                             DIS01230
      IF( KSS .EQ. 0) GO TO 700                                         DIS01240
      CALL LNCNT(4)                                                     DIS01250
      PRINT 650                                                         DIS01260
  650 FORMAT(//,' STEADY-STATE SOLUTION HAS BEEN REACHED IN  DISREG',/) DIS01270
C                                                                       DIS01280
  700 CONTINUE                                                          DIS01290
      IF( IOP(2) .NE. 0 )  RETURN                                       DIS01300
      IF( IOP(1) .EQ. 0 )  RETURN                                       DIS01310
      CALL LNCNT(3)                                                     DIS01320
      I = IOP(3)-I                                                      DIS01330
      PRINT 800, I                                                      DIS01340
  800 FORMAT(/,' F AND P AFTER ',I5, ' STEPS',/)                        DIS01350
      CALL PRNT(F,NF,4H F  ,1)                                          DIS01360
      CALL PRNT(P,NP,4H P  ,1)                                          DIS01370
      RETURN                                                            DIS01380
      END                                                               DIS01390
      SUBROUTINE FACTOR(Q,NQ,D,ND,IOP,IAC,DUMMY)                        FAC00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         FAC00020
      DIMENSION Q(1),D(1),DUMMY(1)                                      FAC00030
      DIMENSION NQ(2),ND(2),NDUM(2)                                     FAC00040
      IOPT = 2                                                          FAC00050
      N = NQ(1)                                                         FAC00060
      M = N**2                                                          FAC00070
      N1 = M + 1                                                        FAC00080
      N2 = N1 + N                                                       FAC00090
C                                                                       FAC00100
      CALL EQUATE(Q,NQ,DUMMY,NQ)                                        FAC00110
      CALL SNVDEC(IOPT,N,N,N,N,DUMMY,NOS,B,IAC,ZTEST,DUMMY(N1),D,IRANK,AFAC00120
     1PLUS,IERR)                                                        FAC00130
      IF( IERR .EQ. 0 ) GO TO 200                                       FAC00140
      CALL LNCNT(5)                                                     FAC00150
      IF( IERR .GT. 0 ) PRINT 100,IERR                                  FAC00160
      IF( IERR .EQ. -1) PRINT 150,ZTEST,IRANK                           FAC00170
  100 FORMAT(//,' IN FACTOR , SNVDEC HAS FAILED TO CONVERGE TO THE ',I4,FAC00180
     1' SINGULAR VALUE AFTER 30 ITERATIONS')                            FAC00190
  150 FORMAT(//,' IN FACTOR, THE MATRIX Q SUBMITTED TO SNVDEC IS CLOSE TFAC00200
     1O A MATRIX OF LOWER RANK USING ZTEST = ',D16.8,/,' IF THE ACCURACYFAC00210
     2 IS REDUCED  THE RANK MAY ALSO BE REDUCED',/,' CURRENT RANK =',I4)FAC00220
      NDUM(1)=N                                                         FAC00230
      NDUM(2)=1                                                         FAC00240
      IF(IERR .EQ. -1)  CALL PRNT(DUMMY(N1),NDUM,4HSNVL,1)              FAC00250
      IF( IERR .GT. 0 ) RETURN                                          FAC00260
C                                                                       FAC00270
  200 CONTINUE                                                          FAC00280
      NDUM(1) = N                                                       FAC00290
C                                                                       FAC00300
      DO 250 J =1,N                                                     FAC00310
      M1 = (J-1)*N + 1                                                  FAC00320
      M2 = J*N                                                          FAC00330
      DO 250 I =M1,M2                                                   FAC00340
      K = N2+I-1                                                        FAC00350
      L = N1+J-1                                                        FAC00360
      IF( DUMMY(L) .EQ. 0.0) GO TO 300                                  FAC00370
      DUMMY(K) = DSQRT(DUMMY(L))*DUMMY(I)                               FAC00380
  250 CONTINUE                                                          FAC00390
      NDUM(2)=N                                                         FAC00400
      GO TO 350                                                         FAC00410
C                                                                       FAC00420
  300 NDUM(2) = J - 1                                                   FAC00430
  350 CONTINUE                                                          FAC00440
      IF( DUMMY(N2) .LT. 0.0 ) CALL SCALE(DUMMY(N2),NDUM,DUMMY(N2),NDUM,FAC00450
     1-1.0)                                                             FAC00460
      CALL TRANP(DUMMY(N2),NDUM,D,ND)                                   FAC00470
C                                                                       FAC00480
      IF( IOP .EQ. 0 ) RETURN                                           FAC00490
      CALL LNCNT(4)                                                     FAC00500
      PRINT 400                                                         FAC00510
  400 FORMAT(//,' FACTOR Q AS (D TRANSPOSE)XD ',/)                      FAC00520
      CALL PRNT(Q,NQ,4H Q  ,1)                                          FAC00530
      CALL PRNT(D,ND,4H D  ,1)                                          FAC00540
      CALL MULT(DUMMY(N2),NDUM,D,ND,DUMMY,NQ)                           FAC00550
      CALL PRNT(DUMMY,NQ,4HDTXD,1)                                      FAC00560
C                                                                       FAC00570
      RETURN                                                            FAC00580
      END                                                               FAC00590
      SUBROUTINE EXPADE (MAX, N, A, EA, IDIG, WK, IERR)                 EXP00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         EXP00020
      DIMENSION A(MAX,N),EA(MAX,N),WK(N,1),C(9)                         EXP00030
      REAL*4 SDIGC,ALOG10                                               EXP00040
      IERR = 0                                                          EXP00050
C     CALCULATE NORM OF A                                               EXP00060
      ANORM = 0.                                                        EXP00070
      DO 10 I=1,N                                                       EXP00080
         S = 0.                                                         EXP00090
         DO 5 J=1,N                                                     EXP00100
            S = S + DABS(A(I,J))                                        EXP00110
 5       CONTINUE                                                       EXP00120
         IF (S .GT. ANORM)  ANORM = S                                   EXP00130
 10   CONTINUE                                                          EXP00140
C ****                                                                  EXP00150
C     CALCULATE ACCURACY ESTIMATE                                       EXP00160
C ****                                                                  EXP00170
      DIGC = 24.*DFLOAT(N)                                              EXP00180
      IF (ANORM .GT. 1.) DIGC = DIGC*ANORM                              EXP00190
      SDIGC=DIGC                                                        EXP00200
      IDIG = 15 - IFIX(ALOG10(SDIGC) + .5)                              EXP00210
C     DETERMINE POWER OF TWO AND NORMALIZATION FACTOR                   EXP00220
C ****                                                                  EXP00230
      M = 0                                                             EXP00240
      IF (ANORM .LE. 1.)  GO TO 27                                      EXP00250
      FACTOR =2.                                                        EXP00260
      DO 15 M=1,46                                                      EXP00270
         IF (ANORM .LE. FACTOR) GO TO 20                                EXP00280
         FACTOR = FACTOR*2.                                             EXP00290
 15   CONTINUE                                                          EXP00300
      GO TO 125                                                         EXP00310
 20   CONTINUE                                                          EXP00320
C ****                                                                  EXP00330
C     NORMALIZE MATRIX                                                  EXP00340
C ****                                                                  EXP00350
      DO 25 I=1,N                                                       EXP00360
         DO 25 J=1,N                                                    EXP00370
            A(I,J) = A(I,J)/FACTOR                                      EXP00380
 25   CONTINUE                                                          EXP00390
 27   CONTINUE                                                          EXP00400
C ****                                                                  EXP00410
C     SET COEFFICIENTS FOR (9,9) PADE TABLE ENTRY                       EXP00420
C ****                                                                  EXP00430
      C(1) = .5                                                         EXP00440
      C(2) = 1.1764705882352D-01                                        EXP00450
      C(3) = 1.7156862745098D-02                                        EXP00460
      C(4) = 1.7156862745098D-03                                        EXP00470
      C(5) = 1.2254901960784D-04                                        EXP00480
      C(6) = 6.2845651080945D-06                                        EXP00490
      C(7) = 2.2444875386051D-07                                        EXP00500
      C(8) = 5.1011080422845D-09                                        EXP00510
      C(9) = 5.6678978247605D-11                                        EXP00520
C ****                                                                  EXP00530
C     CALCULATE PADE NUMERATOR AND DENOMINATOR BY COLUMNS               EXP00540
C ****                                                                  EXP00550
      NP1 = N+1                                                         EXP00560
      NP7 = N+7                                                         EXP00570
      DO 95 J=1,N                                                       EXP00580
C ****                                                                  EXP00590
C        COMPUTE JTH COLUMN OF FIRST NINE POWERS OF A                   EXP00600
C ****                                                                  EXP00610
         DO 35 I=1,N                                                    EXP00620
            S = 0.                                                      EXP00630
            DO 30 L=1,N                                                 EXP00640
               S = S + A(I,L)*A(L,J)                                    EXP00650
 30         CONTINUE                                                    EXP00660
            WK(I,NP1) = S                                               EXP00670
 35      CONTINUE                                                       EXP00680
         DO 45 K=NP1,NP7                                                EXP00690
            KP1 = K+1                                                   EXP00700
            DO 45 I=1,N                                                 EXP00710
               S = 0.                                                   EXP00720
               DO 40 L=1,N                                              EXP00730
                  S = S + A(I,L)*WK(L,K)                                EXP00740
 40            CONTINUE                                                 EXP00750
               WK(I,KP1) = S                                            EXP00760
 45      CONTINUE                                                       EXP00770
C ****                                                                  EXP00780
C        COLLECT TERMS FOR JTH COLUMN OF NUMERATOR AND DENOMINATOR      EXP00790
C ****                                                                  EXP00800
         DO 85 I=1,N                                                    EXP00810
            S = 0.                                                      EXP00820
            U = 0.                                                      EXP00830
            DO 65 L=1,8                                                 EXP00840
               K = N+9-L                                                EXP00850
               KN1 = K-N+1                                              EXP00860
               P = C(KN1)*WK(I,K)                                       EXP00870
               S = S + P                                                EXP00880
              IEO = MOD(KN1,2)                                          EXP00890
              IF (IEO.EQ.0) GO TO 55                                    EXP00900
               U = U - P                                                EXP00910
               GO TO 65                                                 EXP00920
 55            CONTINUE                                                 EXP00930
               U = U + P                                                EXP00940
 65         CONTINUE                                                    EXP00950
            P = C(1)*A(I,J)                                             EXP00960
            S = S + P                                                   EXP00970
            U = U - P                                                   EXP00980
            IF (I .NE. J) GO TO 80                                      EXP00990
            S = S + 1.                                                  EXP01000
            U = U + 1.                                                  EXP01010
 80         CONTINUE                                                    EXP01020
            EA(I,J) = S                                                 EXP01030
            WK(I,J) = U                                                 EXP01040
 85      CONTINUE                                                       EXP01050
 95   CONTINUE                                                          EXP01060
C ****                                                                  EXP01070
C     CALCULATE NORMALIZED EXP(A) BY  WK * EXP(A) = EA                  EXP01080
C ****                                                                  EXP01090
      CALL GAUSEL (MAX,N,WK,N,EA,IERR)                                  EXP01100
      IF (IERR .NE. 0) GO TO 130                                        EXP01110
      IF (M .EQ. 0)  GO TO 130                                          EXP01120
C ****                                                                  EXP01130
C     TAKE OUT EFFECT OF NORMALIZATION ON EXP(A)                        EXP01140
C ****                                                                  EXP01150
      DO 120 K=1,M                                                      EXP01160
         DO 110 I=1,N                                                   EXP01170
            DO 110 J=1,N                                                EXP01180
               S = 0.                                                   EXP01190
               DO 105 L=1,N                                             EXP01200
                  S = S + EA(I,L)*EA(L,J)                               EXP01210
 105           CONTINUE                                                 EXP01220
               WK(I,J) = S                                              EXP01230
 110     CONTINUE                                                       EXP01240
         DO 115 I=1,N                                                   EXP01250
            DO 115 J=1,N                                                EXP01260
               EA(I,J) = WK(I,J)                                        EXP01270
 115     CONTINUE                                                       EXP01280
 120  CONTINUE                                                          EXP01290
C ****                                                                  EXP01300
C     UN-NORMALIZE A                                                    EXP01310
C ****                                                                  EXP01320
      DO 122 I=1,N                                                      EXP01330
         DO 122 J=1,N                                                   EXP01340
            A(I,J) = A(I,J)*FACTOR                                      EXP01350
 122  CONTINUE                                                          EXP01360
      GO TO 130                                                         EXP01370
C ****                                                                  EXP01380
C     NORM OF A IS EXCESSIVE                                            EXP01390
C ****                                                                  EXP01400
 125  CONTINUE                                                          EXP01410
      IERR = 1                                                          EXP01420
C ****                                                                  EXP01430
C     EXIT ROUTINE                                                      EXP01440
C ****                                                                  EXP01450
 130  CONTINUE                                                          EXP01460
      RETURN                                                            EXP01470
      END                                                               EXP01480
      SUBROUTINE VARANC(A,NA,G,NG,Q,NQ,W,NW,IDENT,DISC,IOP,DUMMY)       VAR00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         VAR00020
      DIMENSION A(1),G(1),Q(1),W(1),DUMMY(1)                            VAR00030
      DIMENSION NA(2),NG(2),NQ(2),NW(2),NDUM1(2),IOP(3),IOPT(2)         VAR00040
      LOGICAL IDENT,DISC,SYM                                            VAR00050
      COMMON/TOL/EPSAM,EPSBM,IACM                                       VAR00060
      IF( IOP(1) .EQ. 0 ) GO TO 100                                     VAR00070
      CALL LNCNT(5)                                                     VAR00080
      IF( DISC ) PRINT 25                                               VAR00090
      IF( .NOT. DISC ) PRINT 35                                         VAR00100
   25 FORMAT(//,' PROGRAM TO SOLVE FOR THE STEADY-STATE VARIANCE MATRIX'VAR00110
     1,/,' FOR A LINEAR DISCRETE SYSTEM',/)                             VAR00120
   35 FORMAT(//,' PROGRAM TO SOLVE FOR THE STEADY-STATE VARIANCE MATRIX'VAR00130
     1,/,' FOR A LINEAR CONTINUOUS SYSTEM',/)                           VAR00140
      CALL PRNT(A,NA,4H A  ,1)                                          VAR00150
      IF( .NOT. IDENT ) GO TO 55                                        VAR00160
      CALL LNCNT(3)                                                     VAR00170
      PRINT 45                                                          VAR00180
   45 FORMAT(/,' G IS AN IDENTITY MATRIX ',/)                           VAR00190
      GO TO 65                                                          VAR00200
   55 CONTINUE                                                          VAR00210
      CALL PRNT(G,NG,4H G  ,1)                                          VAR00220
   65 CONTINUE                                                          VAR00230
      IF ( .NOT. IDENT ) GO TO 85                                       VAR00240
      CALL LNCNT(3)                                                     VAR00250
      PRINT 75                                                          VAR00260
   75 FORMAT(/,' INTENSITY MATRIX FOR COVARIANCE OF PROCESS NOISE ',/)  VAR00270
C                                                                       VAR00280
   85 CONTINUE                                                          VAR00290
      CALL PRNT(Q,NQ,4H Q  ,1)                                          VAR00300
C                                                                       VAR00310
  100 CONTINUE                                                          VAR00320
      IF( IDENT ) GO TO 200                                             VAR00330
      CALL MULT(G,NG,Q,NQ,DUMMY,NG)                                     VAR00340
      N1 = NG(1)*NG(2) + 1                                              VAR00350
      CALL TRANP(G,NG,DUMMY(N1),NDUM1)                                  VAR00360
      CALL MULT(DUMMY,NG,DUMMY(N1),NDUM1,Q,NQ)                          VAR00370
C                                                                       VAR00380
      IF( IOP(1) .EQ. 0 ) GO TO 200                                     VAR00390
      CALL LNCNT(3)                                                     VAR00400
      PRINT 75                                                          VAR00410
      CALL PRNT(Q,NQ,4HGQGT,1)                                          VAR00420
C                                                                       VAR00430
  200 CONTINUE                                                          VAR00440
      IF(.NOT. DISC) CALL SCALE(W,NW,W,NW,-1.0)                         VAR00450
      IOPT(1) = IOP(2)                                                  VAR00460
      IOPT(2) = 1                                                       VAR00470
      SYM = .TRUE.                                                      VAR00480
      IF( DISC ) GO TO 300                                              VAR00490
      IF( IOP(3) .EQ. 0 ) GO TO 250                                     VAR00500
      CALL BILIN(A,NA,A,NA,W,NW,IOPT,BETA,SYM,DUMMY)                    VAR00510
      GO TO 400                                                         VAR00520
C                                                                       VAR00530
  250 CONTINUE                                                          VAR00540
      EPSA=EPSAM                                                        VAR00550
      CALL BARSTW(A,NA,A,NA,W,NW,IOPT,SYM,EPSA,EPSA,DUMMY)              VAR00560
      GO TO 400                                                         VAR00570
C                                                                       VAR00580
  300 CONTINUE                                                          VAR00590
      CALL EQUATE(A,NA,DUMMY,NA)                                        VAR00600
      N = NA(1)**2                                                      VAR00610
      N1 = N + 1                                                        VAR00620
      CALL TRANP(A,NA,DUMMY(N1),NA)                                     VAR00630
      N2 = N1 + N                                                       VAR00640
      CALL SUM(DUMMY,NA,W,NW,DUMMY(N1),NA,IOPT,SYM,DUMMY(N2))           VAR00650
C                                                                       VAR00660
  400 CONTINUE                                                          VAR00670
      IF( IOP(1) .EQ. 0 ) RETURN                                        VAR00680
      CALL LNCNT(3)                                                     VAR00690
      PRINT 450                                                         VAR00700
  450 FORMAT(/, ' VARIANCE MATRIX ',/)                                  VAR00710
      CALL PRNT(W,NW,4H W  ,1)                                          VAR00720
C                                                                       VAR00730
      RETURN                                                            VAR00740
      END                                                               VAR00750
      SUBROUTINE CTROL(A,NA,B,NB,C,NC,IOP,IAC,IRANK,DUMMY)              CTR00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         CTR00020
      DIMENSION A(1),B(1),C(1),DUMMY(1)                                 CTR00030
      DIMENSION NA(2),NB(2),NC(2),NV(2),IOP(5)                          CTR00040
      N = NA(1)*NB(2)                                                   CTR00050
      N1 = N+1                                                          CTR00060
      N2 = N1+N                                                         CTR00070
      K = NA(1)-1                                                       CTR00080
      J = 1                                                             CTR00090
C                                                                       CTR00100
      CALL EQUATE(B,NB,DUMMY(N2),NV)                                    CTR00110
      CALL EQUATE(B,NB,DUMMY,NB)                                        CTR00120
100   CONTINUE                                                          CTR00130
      CALL MULT(A,NA,DUMMY,NB,DUMMY(N1),NB)                             CTR00140
      CALL JUXTC(DUMMY(N2),NV,DUMMY(N1),NB,C,NC)                        CTR00150
C                                                                       CTR00160
      IF( J .EQ. K ) GO TO 200                                          CTR00170
C                                                                       CTR00180
      CALL EQUATE(DUMMY(N1),NB,DUMMY,NB)                                CTR00190
      CALL EQUATE(C,NC,DUMMY(N2),NV)                                    CTR00200
      J = J + 1                                                         CTR00210
      GO TO 100                                                         CTR00220
C                                                                       CTR00230
  200 CONTINUE                                                          CTR00240
C                                                                       CTR00250
      IF(IOP(1) .EQ. 0 ) GO TO 300                                      CTR00260
      CALL PRNT(A,NA,4H A  ,1)                                          CTR00270
      CALL PRNT(B,NB,4H B  ,1)                                          CTR00280
      CALL LNCNT(4)                                                     CTR00290
      PRINT 250                                                         CTR00300
  250 FORMAT(//,' THE MATRIX C IS THE CONTROLLABILITY MATRIX FOR THE  A/CTR00310
     1B PAIR',/)                                                        CTR00320
      CALL PRNT(C,NC,4H C  ,1)                                          CTR00330
C                                                                       CTR00340
  300  IF( IOP(2) .EQ. 0 ) RETURN                                       CTR00350
      NOS = 0                                                           CTR00360
      IOPT = 2                                                          CTR00370
      K = NC(2)                                                         CTR00380
      NC(2) = NB(2)*(NA(2)-NB(2)+1)                                     CTR00390
      N = NC(1)*NC(2)                                                   CTR00400
      CALL TRANP(C,NC,DUMMY,NV)                                         CTR00410
      NC(2) = K                                                         CTR00420
      N1 = N + 1                                                        CTR00430
      N2 = N1 + NV(2)                                                   CTR00440
      CALL SNVDEC(IOPT,NV(1),NV(2),NV(1),NV(2),DUMMY,NOS,B,IAC,ZTEST,DUMCTR00450
     1MY(N1),DUMMY(N2),IRANK,A,IERR)                                    CTR00460
      IF( IERR .EQ. 0 ) GO TO 340                                       CTR00470
      CALL LNCNT(5)                                                     CTR00480
      IF( IERR .GT. 0 ) PRINT 310,IERR                                  CTR00490
      IF( IERR .EQ. -1 ) PRINT 320, ZTEST,IRANK                         CTR00500
  310 FORMAT(//,' IN CTROL, SNVDEC HAS FAILED TO CONVERGE TO THE ',I4, 'CTR00510
     1 SINGULAR VALUE AFTER 30 ITERATIONS ')                            CTR00520
  320 FORMAT(//,' IN CTROL, THE MATRIX SUBMITTED TO SNVDEC USING ZTEST =CTR00530
     1',D16.8,' IS CLOSE TO A MATRIX WHICH IS OF LOWER RANK',/,' IF THE CTR00540
     2ACCURACACY IS REDUCED THE RANK MAY ALSO BE REDUCED',/,' CURRENT RACTR00550
     3NK =',I4)                                                         CTR00560
      IF( IERR .GT. 0 ) RETURN                                          CTR00570
C                                                                       CTR00580
  340 CONTINUE                                                          CTR00590
      IF( IOP(3) .EQ. 0 ) GO TO 400                                     CTR00600
      CALL LNCNT(6)                                                     CTR00610
      PRINT 350,ZTEST,IRANK                                             CTR00620
  350 FORMAT(//,' BASED ON THE ZERO-TEST ',D16.8,' THE RANK OF THE CONTRCTR00630
     1OLLABILITY MATRIX IS ',I4,/,' THE SINGULAR VALUES ARE ',/)        CTR00640
      IOPT = 0                                                          CTR00650
      NV(1)= NV(2)                                                      CTR00660
      NV(2)= 1                                                          CTR00670
      CALL PRNT(DUMMY(N1),NV,IOPT,3)                                    CTR00680
C                                                                       CTR00690
  400 IF( IOP(4) .EQ. 0 ) RETURN                                        CTR00700
      N = NA(1)**2                                                      CTR00710
      CALL EQUATE(DUMMY(N2),NA,DUMMY,NA)                                CTR00720
      N1 = N + 1                                                        CTR00730
      N2 = N1 + N                                                       CTR00740
      CALL MULT(A,NA,DUMMY,NA,DUMMY(N1),NA)                             CTR00750
      CALL TRANP(DUMMY,NA,DUMMY(N2),NA)                                 CTR00760
      CALL EQUATE(DUMMY(N2),NA,DUMMY,NA)                                CTR00770
      CALL MULT(DUMMY,NA,DUMMY(N1),NA,DUMMY(N2),NA)                     CTR00780
      CALL MULT(DUMMY,NA,B,NB,DUMMY(N1),NB)                             CTR00790
C                                                                       CTR00800
      IF( IOP(5) .EQ. 0 ) RETURN                                        CTR00810
      CALL LNCNT(5)                                                     CTR00820
      PRINT 500                                                         CTR00830
  500 FORMAT(//,' CONTROLLABILITY CANONICAL FORM ',/, ' (V TRANSPOSE) A CTR00840
     1 V')                                                              CTR00850
      CALL PRNT(DUMMY(N2),NA,IOPT,3)                                    CTR00860
      CALL LNCNT(2)                                                     CTR00870
      PRINT 510                                                         CTR00880
  510 FORMAT(/,' (V TRANSPOSE ) B ')                                    CTR00890
      CALL PRNT(DUMMY(N1),NB,IOPT,3)                                    CTR00900
      CALL LNCNT(2)                                                     CTR00910
      PRINT 520                                                         CTR00920
  520 FORMAT(/,' V TRANSPOSE')                                          CTR00930
      CALL PRNT(DUMMY,NA,IOPT,3)                                        CTR00940
C                                                                       CTR00950
      RETURN                                                            CTR00960
      END                                                               CTR00970
      SUBROUTINE TRNSIT(A,NA,B,NB,H,NH,G,NG,F,NF,V,NV,T,X,NX,DISC,STABL TRN00010
     1E,IOP,DUMMY)                                                      TRN00020
      IMPLICIT REAL*8 (A-H,O-Z)                                         TRN00030
      DIMENSION A(1),B(1),H(1),G(1),F(1),V(1),X(1),DUMMY(1)             TRN00040
      DIMENSION NA(2),NB(2),NH(2),NG(2),NF(2),NV(2),NX(2),T(2),IOP(4)   TRN00050
      DIMENSION NDUM1(2),NDUM2(2)                                       TRN00060
      LOGICAL  DISC,STABLE                                              TRN00070
      N = NA(1)*NA(2)                                                   TRN00080
      N1 = N + 1                                                        TRN00090
      N2 = N + N1                                                       TRN00100
      N3 = N + N2                                                       TRN00110
      N4 = N + N3                                                       TRN00120
      N5 = N + N4                                                       TRN00130
      N6 = N + N5                                                       TRN00140
C                                                                       TRN00150
      CALL LNCNT(4)                                                     TRN00160
      IF(DISC) PRINT 100                                                TRN00170
      IF( .NOT. DISC ) PRINT 120                                        TRN00180
  100 FORMAT(//,' COMPUTATION OF TRANSIENT RESPONSE FOR THE DIGITAL SYSTTRN00190
     1EM ',/)                                                           TRN00200
  120 FORMAT(//,' COMPUTATION OF TRANSIENT RESPONSE FOR THE CONTINUOUS  TRN00210
     1 SYSTEM',/)                                                       TRN00220
      CALL PRNT(A,NA,4H A  ,1)                                          TRN00230
      CALL PRNT(B,NB,4H B  ,1)                                          TRN00240
      IF( (IOP(1) .NE. 1) .AND. (IOP(1) .NE. 0) )  GO TO 180            TRN00250
      CALL LNCNT(3)                                                     TRN00260
      IF( IOP(1) .EQ. 0 ) PRINT 140                                     TRN00270
      IF( IOP(1) .EQ. 1 ) PRINT 160                                     TRN00280
  140 FORMAT(//,' H IS A NULL MATRIX ')                                 TRN00290
  160 FORMAT(//,' H IS AN IDENTITY MATRIX ')                            TRN00300
      GO TO 200                                                         TRN00310
  180 CONTINUE                                                          TRN00320
      CALL PRNT(H,NH,4H H  ,1)                                          TRN00330
  200 CONTINUE                                                          TRN00340
      IF( (IOP(2) .NE. 1) .AND. (IOP(2) .NE. 0) )  GO TO 260            TRN00350
      CALL LNCNT(3)                                                     TRN00360
      IF( IOP(2) .EQ. 0 ) PRINT 220                                     TRN00370
      IF( IOP(2) .EQ. 1 ) PRINT 240                                     TRN00380
  220 FORMAT(//,' G IS A NULL MATRIX')                                  TRN00390
  240 FORMAT(//,' G IS AN IDENTITY MATRIX')                             TRN00400
      GO TO 280                                                         TRN00410
  260 CONTINUE                                                          TRN00420
      CALL PRNT(G,NG,4H G  ,1)                                          TRN00430
  280 CONTINUE                                                          TRN00440
      CALL PRNT(F,NF,4H F  ,1)                                          TRN00450
      IF( (IOP(3) .NE. 0) .AND. (IOP(3) .NE. 1) )  GO TO 295            TRN00460
      CALL LNCNT(3)                                                     TRN00470
      IF(IOP(3).EQ.0) PRINT 285                                         TRN00480
      IF(IOP(3).EQ.1) PRINT 290                                         TRN00490
  285 FORMAT(//,' V IS A NULL MATRIX')                                  TRN00500
  290 FORMAT(//,' V IS AN IDENTITY MATRIX')                             TRN00510
      GO TO 300                                                         TRN00520
  295 CONTINUE                                                          TRN00530
      CALL PRNT(V,NV,4H V  ,1)                                          TRN00540
C                                                                       TRN00550
  300 CONTINUE                                                          TRN00560
      CALL EQUATE(A,NA,DUMMY(N6),NA)                                    TRN00570
      CALL MULT(B,NB,F,NF,DUMMY,NA)                                     TRN00580
      CALL SUBT(A,NA,DUMMY,NA,A,NA)                                     TRN00590
C                                                                       TRN00600
      IF(DISC) GO TO 350                                                TRN00610
      NMAX = T(1)/T(2)                                                  TRN00620
      IOPT = 1                                                          TRN00630
      TT = T(2)                                                         TRN00640
      IF( IOP(3) .NE. 0 )  GO TO 315                                    TRN00650
      CALL EXPSER(A,NA,DUMMY,NA,TT,IOPT,DUMMY(N1))                      TRN00660
      GO TO 400                                                         TRN00670
  315 CONTINUE                                                          TRN00680
      CALL EXPINT(A,NA,DUMMY,NA,DUMMY(N1),NA,TT,IOPT,DUMMY(N2))         TRN00690
      CALL MULT(DUMMY(N1),NA,B,NB,DUMMY(N2),NB)                         TRN00700
      IF( IOP(3) .NE. 1 ) GO TO 325                                     TRN00710
      CALL EQUATE(DUMMY(N2),NB,DUMMY(N1),NX)                            TRN00720
      GO TO 400                                                         TRN00730
  325 CONTINUE                                                          TRN00740
      CALL MULT(DUMMY(N2),NB,V,NV,DUMMY(N1),NX)                         TRN00750
      GO TO 400                                                         TRN00760
  350 CONTINUE                                                          TRN00770
      NMAX = IOP(4)                                                     TRN00780
      CALL EQUATE(A,NA,DUMMY,NA)                                        TRN00790
      IF( IOP(3) .EQ. 0 ) GO TO 400                                     TRN00800
      CALL MULT(B,NB,V,NV,DUMMY(N1),NX)                                 TRN00810
C                                                                       TRN00820
  400 CONTINUE                                                          TRN00830
      CALL LNCNT(4)                                                     TRN00840
      PRINT 420                                                         TRN00850
  420 FORMAT(//,' STRUCTURE OF PRINTING TO FOLLOW',/)                   TRN00860
      CALL LNCNT(6)                                                     TRN00870
      PRINT 440                                                         TRN00880
  440 FORMAT('   TIME OR STAGE ',/,'  STATE - X TRANSPOSE - FROM DX = AXTRN00890
     1 + BU',/,'  OUTPUT - Y TRANSPOSE - FROM Y = HX + GU   IF DIFFERENTTRN00900
     2 FROM X',/,'  CONTROL - U TRANSPOSE - FROM U = -FX + V',//)       TRN00910
C                                                                       TRN00920
      K = 0                                                             TRN00930
      L = 0                                                             TRN00940
      CALL SCALE(F,NF,F,NF,-1.0)                                        TRN00950
C                                                                       TRN00960
  450 CONTINUE                                                          TRN00970
      IF( K .GT. NMAX ) GO TO 800                                       TRN00980
      CALL MULT(F,NF,X,NX,DUMMY(N2),NV)                                 TRN00990
      IF( IOP(3) .NE. 0 ) CALL ADD(DUMMY(N2),NV,V,NV,DUMMY(N2),NV)      TRN01000
      CALL MULT(DUMMY,NA,X,NX,DUMMY(N3),NX)                             TRN01010
      IF( IOP(3) .EQ. 0 ) GO TO 475                                     TRN01020
      CALL ADD(DUMMY(N1),NX,DUMMY(N3),NX,DUMMY(N3),NX)                  TRN01030
  475 CONTINUE                                                          TRN01040
      IF( IOP(2) .EQ. 0 ) GO TO 525                                     TRN01050
      IF( IOP(2) .EQ. 1 ) GO TO 500                                     TRN01060
      CALL MULT(G,NG,DUMMY(N2),NV,DUMMY(N4),NDUM1)                      TRN01070
      GO TO 525                                                         TRN01080
  500 CONTINUE                                                          TRN01090
      CALL EQUATE(DUMMY(N2),NV,DUMMY(N4),NDUM1)                         TRN01100
  525 CONTINUE                                                          TRN01110
      IF( IOP(1) .EQ. 0 ) GO TO 575                                     TRN01120
      IF( IOP(1) .EQ. 1 ) GO TO 550                                     TRN01130
      CALL MULT(H,NH,X,NX,DUMMY(N5),NDUM1)                              TRN01140
      GO TO 575                                                         TRN01150
  550 CONTINUE                                                          TRN01160
      CALL EQUATE(X,NX,DUMMY(N5),NDUM1)                                 TRN01170
  575 CONTINUE                                                          TRN01180
      IF( IOP(2) .EQ. 0 ) GO TO 600                                     TRN01190
      IF( IOP(1) .EQ. 0 ) GO TO 700                                     TRN01200
      CALL ADD(DUMMY(N4),NDUM1,DUMMY(N5),NDUM1,DUMMY(N4),NDUM1)         TRN01210
      GO TO 700                                                         TRN01220
  600 CONTINUE                                                          TRN01230
      IF( IOP(1) .NE. 0 ) CALL EQUATE(DUMMY(N5),NDUM1,DUMMY(N4),NDUM1)  TRN01240
C                                                                       TRN01250
  700 CONTINUE                                                          TRN01260
      CALL LNCNT(5)                                                     TRN01270
      IF( .NOT. DISC ) GO TO 720                                        TRN01280
      PRINT 710,K                                                       TRN01290
  710 FORMAT(////,I5)                                                   TRN01300
      GO TO 740                                                         TRN01310
  720 CONTINUE                                                          TRN01320
      TIME=K*T(2)                                                       TRN01330
      PRINT 730,TIME                                                    TRN01340
  730 FORMAT(////,D16.7)                                                TRN01350
  740 CONTINUE                                                          TRN01360
      CALL TRANP(X,NX,DUMMY(N5),NDUM2)                                  TRN01370
      CALL PRNT(DUMMY(N5),NDUM2,L,3)                                    TRN01380
      IF( (IOP(2) .EQ. 0) .AND. ( (IOP(1) .EQ. 0) .OR. (IOP(1) .EQ. 1) )TRN01390
     1) GO TO 750                                                       TRN01400
      CALL TRANP(DUMMY(N4),NDUM1,DUMMY(N5),NDUM2)                       TRN01410
      CALL PRNT(DUMMY(N5),NDUM2,L,3)                                    TRN01420
  750 CONTINUE                                                          TRN01430
      CALL TRANP(DUMMY(N2),NV,DUMMY(N5),NDUM2)                          TRN01440
      CALL PRNT(DUMMY(N5),NDUM2,L,3)                                    TRN01450
C                                                                       TRN01460
      CALL EQUATE(DUMMY(N3),NX,X,NX)                                    TRN01470
      K = K + 1                                                         TRN01480
      GO TO 450                                                         TRN01490
C                                                                       TRN01500
C                                                                       TRN01510
  800 CONTINUE                                                          TRN01520
      CALL SCALE(F,NF,F,NF,-1.0)                                        TRN01530
      IF( .NOT. STABLE  .OR.  IOP(3) .EQ. 0  )   GO TO 900              TRN01540
      IF( IOP(3) .EQ. 1 )  GO TO 820                                    TRN01550
      CALL MULT(B,NB,V,NV,DUMMY,NX)                                     TRN01560
      GO TO 840                                                         TRN01570
  820 CONTINUE                                                          TRN01580
      CALL EQUATE(B,NB,DUMMY,NX)                                        TRN01590
  840 CONTINUE                                                          TRN01600
      IF( .NOT. DISC )  GO TO 860                                       TRN01610
      CALL UNITY(DUMMY(N1),NA)                                          TRN01620
      CALL SUBT(DUMMY(N1),NA,A,NA,A,NA)                                 TRN01630
  860 CONTINUE                                                          TRN01640
      IFAC = 0                                                          TRN01650
      CALL GELIM(NA(1),NA(1),A,NX(2),DUMMY,DUMMY(N1),IFAC,DUMMY(N2),IERRTRN01660
     1)                                                                 TRN01670
      IF( IERR .EQ. 0 )  GO TO 880                                      TRN01680
      CALL LNCNT(3)                                                     TRN01690
      IF( .NOT. DISC )  PRINT 865                                       TRN01700
      IF( DISC )  PRINT 870                                             TRN01710
  865 FORMAT(//,' IN TRNSIT, THE MATRIX A-BF SUBMITTED TO GELIM IS SINGUTRN01720
     1LAR')                                                             TRN01730
  870 FORMAT(//,' IN TRNSIT, THE MATRIX  I - (A-BF) SUBMITTED TO GELIM ITRN01740
     1S SINGULAR')                                                      TRN01750
      GO TO 900                                                         TRN01760
  880 CONTINUE                                                          TRN01770
      IF( .NOT. DISC )  CALL SCALE(DUMMY,NX,DUMMY,NX,-1.0)              TRN01780
      CALL LNCNT(5)                                                     TRN01790
      PRINT 890                                                         TRN01800
  890 FORMAT(////,' STEADY-STATE VALUE OF  X TRANSPOSE')                TRN01810
      CALL TRANP(DUMMY,NX,DUMMY(N5),NDUM2)                              TRN01820
      CALL PRNT(DUMMY(N5),NDUM2,L,3)                                    TRN01830
C                                                                       TRN01840
  900 CONTINUE                                                          TRN01850
      CALL EQUATE(DUMMY(N6),NA,A,NA)                                    TRN01860
C                                                                       TRN01870
      RETURN                                                            TRN01880
      END                                                               TRN01890
      SUBROUTINE ASMFIL(A,NA,G,NG,H,NH,Q,NQ,R,NR,F,NF,P,NP,IDENT,DISC,N ASM00010
     1EWT,STABLE,FNULL,ALPHA,IOP,DUMMY)                                 ASM00020
      IMPLICIT REAL*8 (A-H,O-Z)                                         ASM00030
      DIMENSION A(1),G(1),H(1),Q(1),R(1),F(1),P(1),DUMMY(1)             ASM00040
      DIMENSION NA(2),NG(2),NH(2),NQ(2),NR(2),NF(2),NP(2),IOPT(5),NDUM1(ASM00050
     12),IOP(1)                                                         ASM00060
      LOGICAL  IDENT,DISC,NEWT,STABLE,FNULL                             ASM00070
      IF( IOP(1) .EQ. 0 ) GO TO 100                                     ASM00080
      CALL LNCNT(4)                                                     ASM00090
      IF(DISC)  PRINT 15                                                ASM00100
      IF( .NOT. DISC )  PRINT 25                                        ASM00110
   15 FORMAT(//,' PROGRAM TO SOLVE THE DISCRETE INFINITE-DURATION OPTIMAASM00120
     1L FILTER PROBLEM',/)                                              ASM00130
   25 FORMAT(//,' PROGRAM TO SOLVE THE CONTINUOUS INFINITE-DURATION OPTIASM00140
     1MAL FILTER PROBLEM',/)                                            ASM00150
      CALL PRNT(A,NA,4H A  ,1)                                          ASM00160
      IF( .NOT.  IDENT )  GO TO 35                                      ASM00170
      CALL LNCNT(3)                                                     ASM00180
      PRINT 30                                                          ASM00190
   30 FORMAT(/,' G IS AN IDENTITY MATRIX',/)                            ASM00200
      GO TO 40                                                          ASM00210
   35 CONTINUE                                                          ASM00220
      CALL PRNT(G,NG,4H G  ,1)                                          ASM00230
   40 CONTINUE                                                          ASM00240
      CALL PRNT(H,NH,4H H  ,1)                                          ASM00250
      CALL LNCNT(3)                                                     ASM00260
      PRINT 45                                                          ASM00270
   45 FORMAT(/,'INTENSITY MATRIX FOR COVARIANCE OF MEASUREMENT NOISE',/)ASM00280
      CALL PRNT(R,NR,4H R  ,1)                                          ASM00290
C                                                                       ASM00300
      IF( .NOT. IDENT ) GO TO 65                                        ASM00310
      CALL LNCNT(3)                                                     ASM00320
      PRINT 55                                                          ASM00330
   55 FORMAT(/,' INTENSITY MATRIX FOR COVARIANCE OF PROCESS NOISE',/)   ASM00340
C                                                                       ASM00350
   65 CONTINUE                                                          ASM00360
      CALL PRNT(Q,NQ,4H Q  ,1)                                          ASM00370
C                                                                       ASM00380
  100 CONTINUE                                                          ASM00390
      IOPT(1)=IOP(2)                                                    ASM00400
      IOPT(2)=IOP(3)                                                    ASM00410
      IOPT(3)=IOP(4)                                                    ASM00420
      IOPT(4)=IOP(5)                                                    ASM00430
      IOPT(5)=0                                                         ASM00440
      K = 0                                                             ASM00450
C                                                                       ASM00460
  200 CONTINUE                                                          ASM00470
      CALL TRANP(A,NA,DUMMY,NA)                                         ASM00480
      CALL EQUATE(DUMMY,NA,A,NA)                                        ASM00490
      CALL TRANP(H,NH,DUMMY,NDUM1)                                      ASM00500
      CALL EQUATE(DUMMY,NDUM1,H,NH)                                     ASM00510
      IF( IDENT )  GO TO 250                                            ASM00520
      CALL TRANP(G,NG,DUMMY,NDUM1)                                      ASM00530
      CALL EQUATE(DUMMY,NDUM1,G,NG)                                     ASM00540
  250 CONTINUE                                                          ASM00550
      IF ( K .EQ. 1 ) RETURN                                            ASM00560
C                                                                       ASM00570
      K = K+1                                                           ASM00580
      CALL ASMREG(A,NA,H,NH,G,NG,Q,NQ,R,NR,F,NF,P,NP,IDENT,DISC,NEWT,ST ASM00590
     1ABLE,FNULL,ALPHA,IOPT,DUMMY)                                      ASM00600
C                                                                       ASM00610
      N1=(NA(1)**2)+3*NA(1)+1                                           ASM00620
      CALL TRANP(F,NF,DUMMY(N1),NDUM1)                                  ASM00630
      CALL EQUATE(DUMMY(N1),NDUM1,F,NF)                                 ASM00640
C                                                                       ASM00650
      IF( IOP(1) .EQ. 0 ) GO TO 200                                     ASM00660
C                                                                       ASM00670
      IF(IDENT) GO TO 300                                               ASM00680
      CALL LNCNT(3)                                                     ASM00690
      PRINT 55                                                          ASM00700
      CALL PRNT(Q,NQ,4HGQGT,1)                                          ASM00710
C                                                                       ASM00720
  300 CONTINUE                                                          ASM00730
      CALL LNCNT(3)                                                     ASM00740
      PRINT 325                                                         ASM00750
  325 FORMAT(/,' FILTER GAIN',/)                                        ASM00760
      CALL PRNT(F,NF,4H F  ,1)                                          ASM00770
      CALL LNCNT(3)                                                     ASM00780
      PRINT 350                                                         ASM00790
  350 FORMAT(/,'STEADY-STATE VARIANCE MATRIX OF RECONSTRUCTION ERROR',/)ASM00800
      CALL PRNT(P,NP,4H P  ,1)                                          ASM00810
      NDUM1(1)=NP(1)                                                    ASM00820
      NDUM1(2)=1                                                        ASM00830
      CALL LNCNT(3)                                                     ASM00840
      PRINT 375                                                         ASM00850
  375 FORMAT(/,' EIGENVALUES OF P ',/)                                  ASM00860
      CALL PRNT(DUMMY,NDUM1,4HEVLP,1)                                   ASM00870
      N1 = NP(1) + 1                                                    ASM00880
      N = NA(1)**2                                                      ASM00890
      N2 = N1 + N + 2*NA(1)                                             ASM00900
      CALL TRANP(DUMMY(N1),NA,DUMMY(N2),NA)                             ASM00910
      CALL PRNT(DUMMY(N2),NA,4HA-FH,1)                                  ASM00920
      N2 = N1 + N                                                       ASM00930
      CALL LNCNT(3)                                                     ASM00940
      PRINT 385                                                         ASM00950
  385 FORMAT(/,' EIGENVALUES OF A-FH MATRIX',/)                         ASM00960
      NDUM1(1) = NA(1)                                                  ASM00970
      NDUM1(2) =  2                                                     ASM00980
      CALL PRNT(DUMMY(N2),NDUM1,0,3)                                    ASM00990
C                                                                       ASM01000
      GO TO 200                                                         ASM01010
C                                                                       ASM01020
      END                                                               ASM01030
      SUBROUTINE EXPMDF (A,NA,B,NB,H,NH,AM,NAM,HM,NHM,Q,NQ,R,NR,F,NF,P, EXP00010
     1NP,HIDENT,HMDENT,DISC,NEWT,STABLE,FNULL,ALPHA,IOP,DUMMY)          EXP00020
      IMPLICIT REAL*8 (A-H,O-Z)                                         EXP00030
      DIMENSION A(1),B(1),H(1),AM(1),HM(1),Q(1),R(1),F(1),P(1),DUMMY(1) EXP00040
      DIMENSION NA(2),NB(2),NH(2),NAM(2),NHM(2),NQ(2),NR(2),NF(2),NP(2),EXP00050
     1IOP(1),IOPT(5),NDUM1(2),NDUM2(2),NDUM3(2)                         EXP00060
      LOGICAL  HIDENT,HMDENT,DISC,NEWT,STABLE,FNULL,SYM                 EXP00070
      COMMON/TOL/EPSAM,EPSBM,IACM                                       EXP00080
      IF( IOP(1) .EQ. 0 ) GO TO 300                                     EXP00090
      CALL LNCNT(6)                                                     EXP00100
      IF( DISC ) PRINT 25                                               EXP00110
      IF( .NOT. DISC ) PRINT 50                                         EXP00120
   25 FORMAT(/,' PROGRAM TO SOLVE ASYMPTOTIC DISCRETE EXPLICIT MODEL-FOLEXP00130
     1LOWING PROBLEM',//,' PLANT DYNAMICS',/)                           EXP00140
   50 FORMAT(/,' PROGRAM TO SOLVE ASYMPTOTIC CONTINUOUS EXPLICIT MODEL-FEXP00150
     1OLLOWING PROBLEM',//,' PLANT DYNAMICS',/)                         EXP00160
      CALL PRNT(A,NA,4H A  ,1)                                          EXP00170
      CALL PRNT(B,NB,4H B  ,1)                                          EXP00180
      IF( HIDENT ) GO TO 75                                             EXP00190
      CALL PRNT(H,NH,4H H  ,1)                                          EXP00200
      GO TO 100                                                         EXP00210
   75 CONTINUE                                                          EXP00220
      CALL LNCNT(3)                                                     EXP00230
      PRINT 85                                                          EXP00240
   85 FORMAT(/,' H IS AN IDENTITY MATRIX',/)                            EXP00250
C                                                                       EXP00260
  100 CONTINUE                                                          EXP00270
      CALL LNCNT(4)                                                     EXP00280
      PRINT 125                                                         EXP00290
  125 FORMAT(//,' MODEL DYNAMICS',/)                                    EXP00300
      CALL PRNT(AM,NAM,4H AM ,1)                                        EXP00310
      IF( HMDENT ) GO TO 175                                            EXP00320
      CALL PRNT(HM,NHM,4H HM ,1)                                        EXP00330
      GO TO 200                                                         EXP00340
  175 CONTINUE                                                          EXP00350
      CALL LNCNT(3)                                                     EXP00360
      PRINT 185                                                         EXP00370
  185 FORMAT(/,' HM IS AN IDENTITY MATRIX ',/)                          EXP00380
C                                                                       EXP00390
  200 CONTINUE                                                          EXP00400
      CALL LNCNT(4)                                                     EXP00410
      PRINT 225                                                         EXP00420
  225 FORMAT(//,' WEIGHTING MATRICES ',/)                               EXP00430
      CALL PRNT(Q,NQ,4H Q  ,1)                                          EXP00440
      CALL PRNT(R,NR,4H R  ,1)                                          EXP00450
C                                                                       EXP00460
  300 CONTINUE                                                          EXP00470
      IF( IOP(2) .EQ. 0 ) GO TO 400                                     EXP00480
      NF(1) = NB(2)                                                     EXP00490
      NF(2) = NA(1)                                                     EXP00500
      NP(1) = NA(1)                                                     EXP00510
      NP(2) = NA(1)                                                     EXP00520
      IOPT(1) = IOP(3)                                                  EXP00530
      IOPT(2) = IOP(4)                                                  EXP00540
      IOPT(3) = IOP(5)                                                  EXP00550
      IOPT(4) =  0                                                      EXP00560
      IOPT(5) =  0                                                      EXP00570
      N1 = NA(1)*NA(2) + 1                                              EXP00580
      CALL EQUATE(Q,NQ,DUMMY,NQ)                                        EXP00590
      CALL ASMREG(A,NA,B,NB,H,NH,DUMMY,NQ,R,NR,F,NF,P,NP,HIDENT,DISC,NE EXP00600
     1WT,STABLE,FNULL,ALPHA,IOPT,DUMMY(N1))                             EXP00610
C                                                                       EXP00620
  400 CONTINUE                                                          EXP00630
      IF( IOP(1) .EQ. 0 ) GO TO 600                                     EXP00640
      CALL LNCNT(4)                                                     EXP00650
      PRINT 425                                                         EXP00660
  425 FORMAT(//,' CONTROL LAW U = -F( COL.(X,XM) ),  F = (F11,F12)',/)  EXP00670
      CALL LNCNT(3)                                                     EXP00680
      PRINT 450                                                         EXP00690
  450 FORMAT(/,' PART OF F MULTIPLYING  X ',/)                          EXP00700
      CALL PRNT(F,NF,4H F11,1)                                          EXP00710
      IF( .NOT. DISC  .AND. IOP(2) .EQ. 0 ) GO  TO 600                  EXP00720
      CALL PRNT(P,NP,4H P11,1)                                          EXP00730
      IF(  IOP(2) .EQ. 0 ) GO TO 600                                    EXP00740
      CALL LNCNT(2)                                                     EXP00750
      PRINT 475                                                         EXP00760
  475 FORMAT(/,' EIGENVALUES OF P11')                                   EXP00770
      NDUM1(1) = NA(1)                                                  EXP00780
      NDUM1(2) = 1                                                      EXP00790
      CALL PRNT(DUMMY(N1),NDUM1,0,3)                                    EXP00800
      N1 = N1 + NDUM1(1)                                                EXP00810
      NDUM1(2) = NA(1)                                                  EXP00820
      CALL LNCNT(2)                                                     EXP00830
      PRINT 500                                                         EXP00840
  500 FORMAT(/,' PLANT CLOSED-LOOP RESPONSE MATRIX A - BF11')           EXP00850
      CALL PRNT(DUMMY(N1),NDUM1,0,3)                                    EXP00860
      CALL LNCNT(2)                                                     EXP00870
      PRINT 525                                                         EXP00880
  525 FORMAT(/,' EIGENVALUES OF CLOSED-LOOP RESPONSE MATRIX')           EXP00890
      N1 = N1 + NDUM1(1)*NDUM1(2)                                       EXP00900
      NDUM1(2) = 2                                                      EXP00910
      CALL PRNT(DUMMY(N1),NDUM1,0,3)                                    EXP00920
C                                                                       EXP00930
  600 CONTINUE                                                          EXP00940
      NF(1)= NB(2)                                                      EXP00950
      NF(2)= NA(1)                                                      EXP00960
      CALL MULT(B,NB,F,NF,DUMMY,NA)                                     EXP00970
      CALL SUBT(A,NA,DUMMY,NA,DUMMY,NA)                                 EXP00980
      IF(  IOP(1).EQ. 0  .OR.  IOP(2) .NE. 0 ) GO TO 700                EXP00990
      CALL LNCNT(2)                                                     EXP01000
      PRINT 500                                                         EXP01010
      CALL PRNT(DUMMY,NA,0,3)                                           EXP01020
C                                                                       EXP01030
  700 CONTINUE                                                          EXP01040
      N1 =  NA(1)**2 +1                                                 EXP01050
      CALL TRANP(DUMMY,NA,DUMMY(N1),NA)                                 EXP01060
      CALL EQUATE(DUMMY(N1),NA,DUMMY,NA)                                EXP01070
      NF(2) = NA(1) + NAM(1)                                            EXP01080
      NP(2) = NF(2)                                                     EXP01090
      IF( .NOT. DISC .AND. IOP(2).EQ. 0 ) NP(2) = NAM(2)                EXP01100
      IOPTT=0                                                           EXP01110
      SYM = .FALSE.                                                     EXP01120
      CALL EQUATE( Q,NQ,DUMMY(N1),NDUM2)                                EXP01130
      IF( HMDENT ) GO TO 725                                            EXP01140
      CALL MULT(Q,NQ,HM,NHM,DUMMY(N1),NDUM2)                            EXP01150
  725 CONTINUE                                                          EXP01160
      IF( HIDENT ) GO TO 750                                            EXP01170
      N2 = N1 + NQ(1)*NHM(2)                                            EXP01180
      CALL TRANP(H,NH,DUMMY(N2),NDUM1)                                  EXP01190
      N3 = N2 + NH(1)*NH(2)                                             EXP01200
      CALL MULT(DUMMY(N2),NDUM1,DUMMY(N1),NHM,DUMMY(N3),NDUM2)          EXP01210
      CALL EQUATE(DUMMY(N3),NDUM2,DUMMY(N1),NDUM2)                      EXP01220
  750 CONTINUE                                                          EXP01230
      N2 = NA(1)**2 + NA(1)*NHM(2) + 1                                  EXP01240
      N3 = NA(1)**2 + 1                                                 EXP01250
      IF( .NOT. DISC .AND. IOP(2) .EQ. 0 ) N3 = 1                       EXP01260
      CALL EQUATE(DUMMY(N1),NDUM2,P(N3),NDUM2)                          EXP01270
      IF( DISC ) GO TO 800                                              EXP01280
      EPSA = EPSAM                                                      EXP01290
      CALL BARSTW(DUMMY,NA,AM,NAM,P(N3),NDUM2,IOPTT,SYM ,EPSA,EPSA,DUMMYEXP01300
     1(N2))                                                             EXP01310
      GO TO 900                                                         EXP01320
C                                                                       EXP01330
  800 CONTINUE                                                          EXP01340
      CALL SCALE(P(N3),NDUM2,P(N3),NDUM2,-1.0)                          EXP01350
      N4 = N2 +NAM(1)**2                                                EXP01360
      CALL EQUATE(AM,NAM,DUMMY(N2),NAM)                                 EXP01370
      CALL SUM(DUMMY,NA,P(N3),NDUM2,DUMMY(N2),NAM,IOPTT,SYM,DUMMY(N4))  EXP01380
C                                                                       EXP01390
  900 CONTINUE                                                          EXP01400
      N2 = NB(2)*NA(1) + 1                                              EXP01410
      CALL TRANP(B,NB,DUMMY,NDUM1)                                      EXP01420
      CALL MULT(DUMMY,NDUM1,P(N3),NDUM2,F(N2),NDUM3)                    EXP01430
      IF( .NOT. DISC ) GO TO 1000                                       EXP01440
      N1 = NB(1)*NB(2) + 1                                              EXP01450
      CALL MULT(DUMMY,NDUM1,P,NA,DUMMY(N1),NDUM2)                       EXP01460
      CALL MULT(DUMMY(N1),NDUM2,B,NB,DUMMY,NR)                          EXP01470
      CALL ADD(R,NR,DUMMY,NR,DUMMY,NR)                                  EXP01480
      GO TO 1100                                                        EXP01490
C                                                                       EXP01500
 1000 CONTINUE                                                          EXP01510
      CALL EQUATE(R,NR,DUMMY,NR)                                        EXP01520
C                                                                       EXP01530
 1100 CONTINUE                                                          EXP01540
      N1 = NR(1)**2 + 1                                                 EXP01550
      CALL SYMPDS(NR(1),NR(1),DUMMY,NHM(2),F(N2),IOPTT,IOPTT,DETERM,ISCAEXP01560
     1LE,DUMMY(N1),IERR)                                                EXP01570
      IF( IERR .EQ. 0 ) GO TO 1200                                      EXP01580
      CALL LNCNT(3)                                                     EXP01590
      PRINT 1150                                                        EXP01600
 1150 FORMAT(/,' IN EXPMDF, THE COEFFICIENT MATRIX FOR SYMPDS IS NOT SY EXP01610
     1MMETRIC POSITIVE DEFINITE ',/)                                    EXP01620
      RETURN                                                            EXP01630
C                                                                       EXP01640
 1200 CONTINUE                                                          EXP01650
      IF( .NOT. DISC ) GO TO 1300                                       EXP01660
      CALL MULT(F(N2),NDUM3,AM,NAM,DUMMY,NDUM1)                         EXP01670
      CALL EQUATE(DUMMY,NDUM1,F(N2),NDUM1)                              EXP01680
 1300 CONTINUE                                                          EXP01690
      IF( IOP(1) .EQ. 0 ) RETURN                                        EXP01700
      CALL LNCNT(3)                                                     EXP01710
      PRINT 1325                                                        EXP01720
 1325 FORMAT(/,' PART OF F MULTIPLYING XM ',/)                          EXP01730
      CALL PRNT(F(N2),NDUM3,4H F12,1)                                   EXP01740
      NDUM1(1) = NA(1)                                                  EXP01750
      NDUM1(2) = NAM(1)                                                 EXP01760
      CALL PRNT(P(N3),NDUM1,4H P12,1)                                   EXP01770
      RETURN                                                            EXP01780
      END                                                               EXP01790
      SUBROUTINE IMPMDF(A,NA,B,NB,H,NH,AM,NAM,BM,NBM,Q,NQ,R,NR,F,NF,P,N IMP00010
     1P,IDENT,DISC,NEWT,STABLE,FNULL,ALPHA,IOP,DUMMY)                   IMP00020
      IMPLICIT REAL*8 (A-H,O-Z)                                         IMP00030
      DIMENSION A(1),B(1),H(1),AM(1),BM(1),Q(1),R(1),F(1),P(1),DUMMY(1) IMP00040
      DIMENSION NA(2),NB(2),NH(2),NAM(2),NBM(2),NQ(2),NR(2),NF(2),NP(2),IMP00050
     1IOP(1),IOPT(5),NDUM1(2)                                           IMP00060
      LOGICAL IDENT,DISC,NEWT,STABLE,FNULL,HIDENT                       IMP00070
      IF( IOP(1) .EQ. 0 ) GO TO 200                                     IMP00080
      CALL LNCNT(6)                                                     IMP00090
      IF( DISC ) PRINT 25                                               IMP00100
      IF( .NOT. DISC ) PRINT 50                                         IMP00110
   25 FORMAT(/,'PROGRAM TO SOLVE ASYMPTOTIC DISCRETE IMPLICIT MODEL-FOLLIMP00120
     1OWING PROBLEM',//,' PLANT DYNAMICS ',/)                           IMP00130
   50 FORMAT(/,' PROGRAM TO SOLVE ASYMPTOTIC CONTINUOUS IMPLICIT MODEL-FIMP00140
     1OLLOWING PROBLEM',//,' PLANT DYNAMICS',/)                         IMP00150
      CALL PRNT(A,NA,4H A  ,1)                                          IMP00160
      CALL PRNT(B,NB,4H B  ,1)                                          IMP00170
      IF( IDENT ) GO TO 75                                              IMP00180
      CALL PRNT(H,NH,4H H  ,1)                                          IMP00190
      GO TO 100                                                         IMP00200
   75 CONTINUE                                                          IMP00210
      CALL LNCNT(3)                                                     IMP00220
      PRINT 85                                                          IMP00230
   85 FORMAT(/,' H IS AN IDENTITY MATRIX',/)                            IMP00240
C                                                                       IMP00250
  100 CONTINUE                                                          IMP00260
      CALL LNCNT(4)                                                     IMP00270
      PRINT 125                                                         IMP00280
  125 FORMAT(//,' MODEL DYNAMICS',/)                                    IMP00290
      CALL PRNT(AM,NAM,4H AM ,1)                                        rMP00300
      CALL PRNT(BM,NBM,4H BM ,1)                                        IMP00310
      CALL LNCNT(4)                                                     IMP00320
      PRINT 150                                                         IMP00330
  150 FORMAT(//,' WEIGHTING MATRICES',/)                                IMP00340
      CALL PRNT(Q,NQ,4H Q  ,1)                                          IMP00350
      CALL PRNT(R,NR,4H R  ,1)                                          IMP00360
C                                                                       IMP00370
  200 CONTINUE                                                          IMP00380
      N = NA(1)**2                                                      IMP00390
      N1 = N + 1                                                        IMP00400
      IF( .NOT. IDENT ) GO TO 300                                       IMP00410
      CALL SUBT(A,NA,AM,NAM,DUMMY,NA)                                   IMP00420
      CALL SUBT(B,NB,BM,NBM,DUMMY(N1),NB)                               IMP00430
      GO TO 400                                                         IMP00440
C                                                                       IMP00450
  300 CONTINUE                                                          IMP00460
      CALL MULT(H,NH,A,NA,DUMMY,NH)                                     IMP00470
      CALL MULT(AM,NAM,H,NH,DUMMY(N1),NH)                               IMP00480
      CALL SUBT(DUMMY,NH,DUMMY(N1),NH,DUMMY,NH)                         IMP00490
      CALL MULT(H,NH,B,NB,DUMMY(N1),NBM)                                IMP00500
      CALL SUBT(DUMMY(N1),NBM,BM,NBM,DUMMY(N1),NBM)                     IMP00510
C                                                                       IMP00520
  400 CONTINUE                                                          IMP00530
      IF( IOP(1) .EQ. 0 ) GO TO 500                                     IMP00540
      CALL LNCNT(3)                                                     IMP00550
      PRINT 450                                                         IMP00560
  450 FORMAT(//,' MATRIX HA - AMH')                                     IMP00570
      CALL PRNT(DUMMY,NH,0,3)                                           IMP00580
      CALL LNCNT(3)                                                     IMP00590
      PRINT 475                                                         IMP00600
  475 FORMAT(//,' MATRIX HB - BM')                                      IMP00610
      CALL PRNT(DUMMY(N1),NBM,0,3)                                      IMP00620
C                                                                       IMP00630
  500 CONTINUE                                                          IMP00640
      N2 = N1 + N                                                       IMP00650
      N3 = N2 + N                                                       IMP00660
      N4 = N3 + N                                                       IMP00670
      CALL MULT(Q,NQ,DUMMY,NH,DUMMY(N2),NH)                             IMP00680
      CALL MULT(Q,NQ,DUMMY(N1),NBM,DUMMY(N3),NBM)                       IMP00690
      CALL TRANP(DUMMY,NH,DUMMY(N4),NDUM1)                              IMP00700
      CALL MULT(DUMMY(N4),NDUM1,DUMMY(N2),NH,DUMMY,NA)                  IMP00710
      CALL MULT(DUMMY(N4),NDUM1,DUMMY(N3),NBM,DUMMY(N2),NB)             IMP00720
      CALL TRANP(DUMMY(N1),NBM,DUMMY(N4),NDUM1)                         IMP00730
      CALL SCALE(DUMMY(N2),NB,DUMMY(N1),NB,2.0)                         IMP00740
      CALL MULT(DUMMY(N4),NDUM1,DUMMY(N3),NBM,DUMMY(N2),NR)             IMP00750
      CALL ADD(DUMMY(N2),NR,R,NR,DUMMY(N2),NR)                          IMP00760
      IF( IOP(1) .EQ. 0 ) GO TO 600                                     IMP00770
      CALL LNCNT(3)                                                     IMP00780
      PRINT 525                                                         IMP00790
  525 FORMAT(//,' MATRIX (HA - AMH TRANSPOSE)Q( HA - AMH)')             IMP00800
      CALL PRNT(DUMMY,NA,0,3)                                           IMP00810
      CALL LNCNT(3)                                                     IMP00820
      PRINT 550                                                         IMP00830
  550 FORMAT(//,' MATRIX 2( HA - AMH  TRANSPOSE)Q( HB - BM)')           IMP00840
      CALL PRNT(DUMMY(N1),NB,0,3)                                       IMP00850
      CALL LNCNT(3)                                                     IMP00860
      PRINT 575                                                         IMP00870
  575 FORMAT(//,' MATRIX ( HB - BM TRANSPOSE)Q( HB - BM ) + R')         IMP00880
      CALL PRNT(DUMMY(N2),NR,0,3)                                       IMP00890
C                                                                       IMP00900
  600 CONTINUE                                                          IMP00910
      IOPT(1)= 0                                                        IMP00920
      IOPT(2)= 1                                                        IMP00930
      IOPT(3)= 1                                                        IMP00940
      N5 = N4 + N                                                       IMP00950
      CALL EQUATE(A,NA,DUMMY(N3),NA)                                    IMP00960
      CALL PREFIL(DUMMY(N3),NA,B,NB,DUMMY,NA,DUMMY(N1),NB,DUMMY(N2),NR,DIMP00970
     1UMMY(N4),NF,IOPT,DUMMY(N5))                                       IMP00980
      IF(IOP(1) .EQ. 0 ) GO TO 700                                      IMP00990
      CALL LNCNT(3)                                                     IMP01000
      PRINT 625                                                         IMP01010
  625 FORMAT(//,' PREFILTER GAIN')                                      IMP01020
      CALL PRNT(DUMMY(N4),NF,0,3)                                       IMP01030
      CALL LNCNT(3)                                                     IMP01040
      PRINT 650                                                         IMP01050
  650 FORMAT(//,' MATRIX A - B(PREFILTER)')                             IMP01060
      CALL PRNT(DUMMY(N3),NA,0,3)                                       IMP01070
      CALL LNCNT(3)                                                     IMP01080
      PRINT 675                                                         IMP01090
  675 FORMAT(//,' MODIFIED STATE VECTOR WEIGHTING MATRIX')              IMP01100
      CALL PRNT(DUMMY,NA,0,3)                                           IMP01110
C                                                                       IMP01120
  700 CONTINUE                                                          IMP01130
      CALL EQUATE(DUMMY(N4),NF,DUMMY(N1),NF)                            IMP01140
C                                                                       IMP01150
      IF( IOP(2) .EQ. -1000 ) RETURN                                    IMP01160
C                                                                       IMP01170
      IOPT(1) = IOP(2)                                                  IMP01180
      IOPT(2) = IOP(3)                                                  IMP01190
      IOPT(3) = IOP(4)                                                  IMP01200
      IOPT(4) = 0                                                       IMP01210
      IOPT(5) = 0                                                       IMP01220
      HIDENT = .TRUE.                                                   IMP01230
      CALL ASMREG(DUMMY(N3),NA,B,NB,H,NH,DUMMY,NA,DUMMY(N2),NR,F,NF,P,N IMP01240
     1P,HIDENT,DISC,NEWT,STABLE,FNULL,ALPHA,IOPT,DUMMY(N4))             IMP01250
      IF( IOP(1) .EQ. 0 ) GO TO 800                                     IMP01260
      CALL LNCNT(3)                                                     IMP01270
      PRINT 725                                                         IMP01280
  725 FORMAT(//,' GAIN FROM ASMREG')                                    IMP01290
      CALL PRNT(F,NF,0,3)                                               IMP01300
      CALL LNCNT(3)                                                     IMP01310
      PRINT 750                                                         IMP01320
  750 FORMAT(//,' SOLUTION OF ASSOCIATED STEADY-STATE RICCATI EQUATION')IMP01330
      CALL PRNT(P,NP,0,3)                                               IMP01340
      CALL LNCNT(3)                                                     IMP01350
      PRINT 775                                                         IMP01360
  775 FORMAT(//,' EIGENVALUES OF P')                                    IMP01370
      NDUM1(1)= NA(1)                                                   IMP01380
      NDUM1(2)= 1                                                       IMP01390
      CALL PRNT(DUMMY(N4),NDUM1,0,3)                                    IMP01400
C                                                                       IMP01410
  800 CONTINUE                                                          IMP01420
      CALL ADD(F,NF,DUMMY(N1),NF,F,NF)                                  IMP01430
      IF( IOP(1) .EQ. 0 ) RETURN                                        IMP01440
      CALL LNCNT(4)                                                     IMP01450
      PRINT 825                                                         IMP01460
  825 FORMAT(//,' GAIN FOR MODEL-FOLLOWING CONTROL LAW, U = - F X  , F =IMP01470
     1(PREFILTER) + (ASMREG)',/)                                        IMP01480
      CALL PRNT(F,NF,4H F  ,1)                                          IMP01490
      N6 = N4 + NA(1)                                                   IMP01500
      CALL PRNT(DUMMY(N6),NA,4HA-BF,1)                                  IMP01510
      NDUM1(2) = 2                                                      IMP01520
      N6 = N6 + N                                                       IMP01530
      CALL LNCNT(3)                                                     IMP01540
      PRINT 850                                                         IMP01550
  850 FORMAT(//,' EIGENVALUES OF A-BF')                                 IMP01560
      CALL PRNT(DUMMY(N6),NDUM1,0,3)                                    IMP01570
C                                                                       IMP01580
      RETURN                                                            IMP01590
      END                                                               IMP01600
      SUBROUTINE GAUSEL (MAX, N, A, NR, B, IERR)                        GAU00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         GAU00020
C   FUNCTION              - COMPUTES SOLUTION TO A SET OF SIMULTANEOUS  GAU00030
C                             LINEAR EQUATIONS (DOES NOT GIVE PIVOT OR  GAU00040
C                             DETERMINANT DATA)                         GAU00050
C   USAGE                 - CALL GAUSEL (MAX,N,A,NR,B,IERR)             GAU00060
C   PARAMETERS  MAX       - MAXIMUM ROW DIMENSION OF B                  GAU00070
C               N         - ORDER OF A                                  GAU00080
C               A(N,N)    - INPUT MATRIX OF COEFFICIENTS (DESTROYED)    GAU00090
C               NR        - NUMBER OF COLUMNS IN B                      GAU00100
C               B(MAX,NR) - MATRIX OF CONSTANTS (REPLACED BY SOLUTIONS) GAU00110
C               IERR      - INTEGER ERROR CODE                          GAU00120
C                             = 0   NORMAL RETURN                       GAU00130
C                             = 2   INPUT MATRIX IS SINGULAR            GAU00140
C   REQUIRED ROUTINES     - NONE                                        GAU00150
C                                                                       GAU00160
C     SOURCE                                                            GAU00170
C              NASA, LRC, ANALYSIS AND COMPUTATION DIVISION SUBPROGRAM  GAU00180
C              LIBRARY                                                  GAU00190
C ****                                                                  GAU00200
      DIMENSION A(N,N),B(MAX,NR)                                        GAU00210
      NM1 = N-1                                                         GAU00220
      IF (NM1 .EQ. 0) GO TO 140                                         GAU00230
C ****                                                                  GAU00240
C     FIND LARGEST REMAINING ELEMENT IN I-TH COLUMN FOR PIVOT           GAU00250
C ****                                                                  GAU00260
      DO 100 I=1,NM1                                                    GAU00270
         BIG = 0.                                                       GAU00280
         DO 20 K=I,N                                                    GAU00290
            TERM = DABS(A(K,I))                                         GAU00300
            IF (TERM - BIG) 20,20,10                                    GAU00310
  10        BIG = TERM                                                  GAU00320
            L = K                                                       GAU00330
  20     CONTINUE                                                       GAU00340
         IF (BIG) 40,30,40                                              GAU00350
  30     IERR = 2                                                       GAU00360
         RETURN                                                         GAU00370
  40     IF (I-L) 50,80,50                                              GAU00380
C ****                                                                  GAU00390
C     PIVOT ROWS OF A AND B                                             GAU00400
C ****                                                                  GAU00410
  50     CONTINUE                                                       GAU00420
         DO 60 J=1,N                                                    GAU00430
            TEMP = A(I,J)                                               GAU00440
            A(I,J) = A(L,J)                                             GAU00450
            A(L,J) = TEMP                                               GAU00460
  60     CONTINUE                                                       GAU00470
         DO 70 J=1,NR                                                   GAU00480
            TEMP = B(I,J)                                               GAU00490
            B(I,J) = B(L,J)                                             GAU00500
            B(L,J) = TEMP                                               GAU00510
  70     CONTINUE                                                       GAU00520
  80     CONTINUE                                                       GAU00530
C ****                                                                  GAU00540
C     STORE PIVOT AND PERFORM COLUMN OPERATIONS ON A AND B              GAU00550
C ****                                                                  GAU00560
         IP1 = I+1                                                      GAU00570
         DO 100 II=IP1,N                                                GAU00580
            A(II,I) = A(II,I)/A(I,I)                                    GAU00590
            X3 = A(II,I)                                                GAU00600
            DO 90 K=IP1,N                                               GAU00610
               A(II,K) = A(II,K) - X3*A(I,K)                            GAU00620
  90        CONTINUE                                                    GAU00630
            DO 100 K=1,NR                                               GAU00640
               B(II,K) = B(II,K) - X3*B(I,K)                            GAU00650
 100  CONTINUE                                                          GAU00660
C ****                                                                  GAU00670
C     PERFORM BACK SUBSTITUTION                                         GAU00680
C ****                                                                  GAU00690
      DO 110 IC=1,NR                                                    GAU00700
         B(N,IC) = B(N,IC)/A(N,N)                                       GAU00710
 110  CONTINUE                                                          GAU00720
      DO 130 KK=1,NM1                                                   GAU00730
         I = N-KK                                                       GAU00740
         IP1 = I+1                                                      GAU00750
         DO 130 J=1,NR                                                  GAU00760
            SUM = B(I,J)                                                GAU00770
            DO 120 K=IP1,N                                              GAU00780
               SUM = SUM - A(I,K)*B(K,J)                                GAU00790
 120        CONTINUE                                                    GAU00800
            B(I,J) = SUM/A(I,I)                                         GAU00810
 130  CONTINUE                                                          GAU00820
      RETURN                                                            GAU00830
 140  CONTINUE                                                          GAU00840
      IF (A(1,1) .EQ. 0.) GO TO 300                                     GAU00850
      DO 150 J=1,NR                                                     GAU00860
         B(1,J) = B(1,J)/A(1,1)                                         GAU00870
 150  CONTINUE                                                          GAU00880
      RETURN                                                            GAU00890
  300 IERR = 2                                                          GAU00900
      RETURN                                                            GAU00910
      END                                                               GAU00920
      SUBROUTINE HQR(NM,N,LOW,IGH,H,WR,WI,IERR)                         HQR00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         HQR00020
       REAL*8 NORM,MACHEP                                               HQR00030
      INTEGER I,J,K,L,M,N,EN,LL,MM,NA,NM,IGH,ITS,LOW,MP2,ENM2,IERR      HQR00040
      DIMENSION H(NM,N),WR(N),WI(N)                                     HQR00050
C     REAL P,Q,R,S,T,W,X,Y,ZZ,NORM,MACHEP                               HQR00060
      REAL*8 DSQRT,DABS,DSIGN                                           HQR00070
C     INTEGER MIN0                                                      HQR00080
      LOGICAL NOTLAS                                                    HQR00090
C                                                                       HQR00100
C                                                                       HQR00110
C     ********** MACHEP IS A MACHINE DEPENDENT PARAMETER SPECIFYING     HQR00120
C                THE RELATIVE PRECISION OF FLOATING POINT ARITHMETIC.   HQR00130
C                                                                       HQR00140
C                                                                       HQR00150
      MACHEP = 16.**(-13)                                               HQR00160
C                                                                       HQR00170
      IERR = 0                                                          HQR00180
      NORM = 0.0D0                                                      HQR00190
      K = 1                                                             HQR00200
C     ********** STORE ROOTS ISOLATED BY BALANC                         HQR00210
C                AND COMPUTE MATRIX NORM **********                     HQR00220
      DO 50 I = 1, N                                                    HQR00230
C                                                                       HQR00240
         DO 40 J = K, N                                                 HQR00250
   40    NORM = NORM + DABS(H(I,J))                                     HQR00260
C                                                                       HQR00270
         K = I                                                          HQR00280
         IF (I .GE. LOW .AND. I .LE. IGH) GO TO 50                      HQR00290
         WR(I) = H(I,I)                                                 HQR00300
         WI(I) = 0.0D0                                                  HQR00310
   50 CONTINUE                                                          HQR00320
C                                                                       HQR00330
      EN = IGH                                                          HQR00340
      T = 0.0D0                                                         HQR00350
C     ********** SEARCH FOR NEXT EIGENVALUES **********                 HQR00360
   60 IF (EN .LT. LOW) GO TO 1001                                       HQR00370
      ITS = 0                                                           HQR00380
      NA = EN - 1                                                       HQR00390
      ENM2 = NA - 1                                                     HQR00400
C     ********** LOOK FOR SINGLE SMALL SUB-DIAGONAL ELEMENT             HQR00410
C                FOR L=EN STEP -1 UNTIL LOW DO -- **********            HQR00420
   70 DO 80 LL = LOW, EN                                                HQR00430
         L = EN + LOW - LL                                              HQR00440
         IF (L .EQ. LOW) GO TO 100                                      HQR00450
         S = DABS(H(L-1,L-1)) + DABS(H(L,L))                            HQR00460
         IF (S .EQ. 0.0D0) S = NORM                                     HQR00470
         IF (DABS(H(L,L-1)) .LE. MACHEP * S) GO TO 100                  HQR00480
   80 CONTINUE                                                          HQR00490
C     ********** FORM SHIFT **********                                  HQR00500
  100 X = H(EN,EN)                                                      HQR00510
      IF (L .EQ. EN) GO TO 270                                          HQR00520
      Y = H(NA,NA)                                                      HQR00530
      W = H(EN,NA) * H(NA,EN)                                           HQR00540
      IF (L .EQ. NA) GO TO 280                                          HQR00550
      IF (ITS .EQ. 30) GO TO 1000                                       HQR00560
      IF (ITS .NE. 10 .AND. ITS .NE. 20) GO TO 130                      HQR00570
C     ********** FORM EXCEPTIONAL SHIFT **********                      HQR00580
      T = T + X                                                         HQR00590
C                                                                       HQR00600
      DO 120 I = LOW, EN                                                HQR00610
  120 H(I,I) = H(I,I) - X                                               HQR00620
C                                                                       HQR00630
      S = DABS(H(EN,NA)) + DABS(H(NA,ENM2))                             HQR00640
      X = 0.75 * S                                                      HQR00650
      Y = X                                                             HQR00660
      W = -0.4375 * S * S                                               HQR00670
  130 ITS = ITS + 1                                                     HQR00680
C     ********** LOOK FOR TWO CONSECUTIVE SMALL                         HQR00690
C                SUB-DIAGONAL ELEMENTS.                                 HQR00700
C                FOR M=EN-2 STEP -1 UNTIL L DO -- **********            HQR00710
      DO 140 MM = L, ENM2                                               HQR00720
         M = ENM2 + L - MM                                              HQR00730
         ZZ = H(M,M)                                                    HQR00740
         R = X - ZZ                                                     HQR00750
         S = Y - ZZ                                                     HQR00760
         P = (R * S - W) / H(M+1,M) + H(M,M+1)                          HQR00770
         Q = H(M+1,M+1) - ZZ - R - S                                    HQR00780
         R = H(M+2,M+1)                                                 HQR00790
         S = DABS(P) + DABS(Q) + DABS(R)                                HQR00800
         P = P / S                                                      HQR00810
         Q = Q / S                                                      HQR00820
         R = R / S                                                      HQR00830
         IF (M .EQ. L) GO TO 150                                        HQR00840
         IF (DABS(H(M,M-1)) * (DABS(Q) + DABS(R)) .LE. MACHEP * DABS(P) HQR00850
     X    * (DABS(H(M-1,M-1)) + DABS(ZZ) + DABS(H(M+1,M+1)))) GO TO 150 HQR00860
  140 CONTINUE                                                          HQR00870
C                                                                       HQR00880
  150 MP2 = M + 2                                                       HQR00890
C                                                                       HQR00900
      DO 160 I = MP2, EN                                                HQR00910
         H(I,I-2) = 0.0D0                                               HQR00920
         IF (I .EQ. MP2) GO TO 160                                      HQR00930
         H(I,I-3) = 0.0D0                                               HQR00940
  160 CONTINUE                                                          HQR00950
C     ********** DOUBLE QR STEP INVOLVING ROWS L TO EN AND              HQR00960
C                COLUMNS M TO EN **********                             HQR00970
      DO 260 K = M, NA                                                  HQR00980
         NOTLAS = K .NE. NA                                             HQR00990
         IF (K .EQ. M) GO TO 170                                        HQR01000
         P = H(K,K-1)                                                   HQR01010
         Q = H(K+1,K-1)                                                 HQR01020
         R = 0.0D0                                                      HQR01030
         IF (NOTLAS) R = H(K+2,K-1)                                     HQR01040
         X = DABS(P) + DABS(Q) + DABS(R)                                HQR01050
         IF (X .EQ. 0.0D0) GO TO 260                                    HQR01060
         P = P / X                                                      HQR01070
         Q = Q / X                                                      HQR01080
         R = R / X                                                      HQR01090
  170    S = DSIGN(DSQRT(P*P+Q*Q+R*R),P)                                qQR01100
         IF (K .EQ. M) GO TO 180                                        HQR01110
         H(K,K-1) = -S * X                                              HQR01120
         GO TO 190                                                      qQR01130
  180    IF (L .NE. M) H(K,K-1) = -H(K,K-1)                             qQR01140
  190    P = P + S                                                      HQR01150
         X = P / S                                                      HQR01160
         Y = Q / S                                                      HQR01170
         ZZ = R / S                                                     HQR01180
         Q = Q / P                                                      HQR01190
         R = R / P                                                      HQR01200
C     ********** ROW MODIFICATION **********                            HQR01210
         DO 210 J = K, EN                                               HQR01220
            P = H(K,J) + Q * H(K+1,J)                                   HQR01230
            IF (.NOT. NOTLAS) GO TO 200                                 HQR01240
            P = P + R * H(K+2,J)                                        HQR01250
            H(K+2,J) = H(K+2,J) - P * ZZ                                HQR01260
  200       H(K+1,J) = H(K+1,J) - P * Y                                 HQR01270
            H(K,J) = H(K,J) - P * X                                     HQR01280
  210    CONTINUE                                                       HQR01290
C                                                                       HQR01300
         J = MIN0(EN,K+3)                                               HQR01310
C     ********** COLUMN MODIFICATION **********                         HQR01320
         DO 230 I = L, J                                                HQR01330
            P = X * H(I,K) + Y * H(I,K+1)                               HQR01340
            IF (.NOT. NOTLAS) GO TO 220                                 HQR01350
            P = P + ZZ * H(I,K+2)                                       HQR01360
            H(I,K+2) = H(I,K+2) - P * R                                 HQR01370
  220       H(I,K+1) = H(I,K+1) - P * Q                                 HQR01380
            H(I,K) = H(I,K) - P                                         HQR01390
  230    CONTINUE                                                       HQR01400
C                                                                       HQR01410
  260 CONTINUE                                                          HQR01420
C                                                                       HQR01430
      GO TO 70                                                          HQR01440
C     ********** ONE ROOT FOUND **********                              HQR01450
  270 WR(EN) = X + T                                                    HQR01460
      WI(EN) = 0.0D0                                                    HQR01470
      EN = NA                                                           HQR01480
      GO TO 60                                                          HQR01490
C     ********** TWO ROOTS FOUND **********                             HQR01500
  280 P = (Y - X) / 2.0D0                                               HQR01510
      Q = P * P + W                                                     HQR01520
      ZZ = DSQRT(DABS(Q))                                               HQR01530
      X = X + T                                                         HQR01540
      IF (Q .LT. 0.0D0) GO TO 320                                       HQR01550
C     ********** REAL PAIR **********                                   qQR01560
      ZZ = P + DSIGN(ZZ,P)                                              HQR01570
      WR(NA) = X + ZZ                                                   HQR01580
      WR(EN) = WR(NA)                                                   HQR01590
      IF (ZZ .NE. 0.0D0) WR(EN) = X - W / ZZ                            HQR01600
      WI(NA) = 0.0D0                                                    HQR01610
      WI(EN) = 0.0D0                                                    qQR01620
      GO TO 330                                                         HQR01630
C     ********** COMPLEX PAIR **********                                HQR01640
  320 WR(NA) = X + P                                                    HQR01650
      WR(EN) = X + P                                                    HQR01660
      WI(NA) = ZZ                                                       qQR01670
      WI(EN) = -ZZ                                                      HQR01680
  330 EN = ENM2                                                         HQR01690
      GO TO 60                                                          HQR01700
C     ********** SET ERROR -- NO CONVERGENCE TO AN                      HQR01710
C                EIGENVALUE AFTER 30 ITERATIONS **********              HQR01720
 1000 IERR = EN                                                         HQR01730
 1001 RETURN                                                            HQR01740
C     ********** LAST CARD OF HQR **********                            HQR01750
      END                                                               HQR01760
      SUBROUTINE INVIT(NM,N,A,WR,WI,SELECT,MM,M,Z,IERR,RM1,RV1,RV2)     INV00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         INV00020
      REAL*8 NORM,NORMV,ILAMBD,MACHEP                                   INV00030
      INTEGER I,J,K,L,M,N,S,II,IP,MM,MP,NM,NS,N1,UK,IP1,ITS,KM1,IERR    rNV00040
      DIMENSION A(NM,N),WR(N),WI(N),Z(NM,MM),RM1(N,N),RV1(N),RV2(N)     INV00050
C     REAL T,W,X,Y,EPS3,NORM,NORMV,GROWTO,ILAMBD,MACHEP,RLAMBD,UKROOT   INV00060
      REAL*8 DSQRT,CDABS,DABS,DFLOAT                                    INV00070
      INTEGER IABS                                                      rNV00080
      LOGICAL*1 SELECT(N)                                               INV00090
      COMPLEX*16 Z3,DCMPLX                                              INV00100
      REAL*8 DREAL,DIMAG                                                INV00110
C                                                                       INV00120
      MACHEP = 16.**(-13)                                               INV00130
C                                                                       INV00140
      IERR = 0                                                          INV00150
      UK = 0                                                            rNV00160
      S = 1                                                             INV00170
C     ********** IP = 0, REAL EIGENVALUE                                INV00180
C                     1, FIRST OF CONJUGATE COMPLEX PAIR                INV00190
C                    -1, SECOND OF CONJUGATE COMPLEX PAIR **********    INV00200
      IP = 0                                                            INV00210
      N1 = N - 1                                                        rNV00220
C                                                                       INV00230
      DO 980 K = 1, N                                                   INV00240
         IF (WI(K) .EQ. 0.0D0 .OR. IP .LT. 0) GO TO 100                 INV00250
         IP = 1                                                         INV00260
         IF (SELECT(K) .AND. SELECT(K+1)) SELECT(K+1) = .FALSE.         INV00270
  100    IF (.NOT. SELECT(K)) GO TO 960                                 INV00280
         IF (WI(K) .NE. 0.0D0) S = S + 1                                INV00290
         IF (S .GT. MM) GO TO 1000                                      INV00300
         IF (UK .GE. K) GO TO 200                                       INV00310
C     ********** CHECK FOR POSSIBLE SPLITTING **********                INV00320
         DO 120 UK = K, N                                               INV00330
            IF (UK .EQ. N) GO TO 140                                    INV00340
            IF (A(UK+1,UK) .EQ. 0.0D0) GO TO 140                        INV00350
  120    CONTINUE                                                       INV00360
C     ********** COMPUTE INFINITY NORM OF LEADING UK BY UK              INV00370
C                (HESSENBERG) MATRIX **********                         INV00380
  140    NORM = 0.0D0                                                   INV00390
         MP = 1                                                         INV00400
C                                                                       INV00410
         DO 180 I = 1, UK                                               INV00420
            X = 0.0D0                                                   INV00430
C                                                                       INV00440
            DO 160 J = MP, UK                                           INV00450
  160       X = X + DABS(A(I,J))                                        INV00460
C                                                                       INV00470
            IF (X .GT. NORM) NORM = X                                   INV00480
            MP = I                                                      INV00490
  180    CONTINUE                                                       INV00500
C     ********** EPS3 REPLACES ZERO PIVOT IN DECOMPOSITION              INV00510
C                AND CLOSE ROOTS ARE MODIFIED BY EPS3-**********       +rNV00520
         IF (NORM .EQ. 0.0D0) NORM = 1.0D0                              INV00530
         EPS3 = MACHEP * NORM                                           INV00540
C     ********** GROWTO IS THE CRITERION FOR THE GROWTH **********      INV00550
         UKROOT = DSQRT(DFLOAT(UK))                                     INV00560
         GROWTO = 1.0D-1 / UKROOT                                       INV00570
  200    RLAMBD = WR(K)                                                 INV00580
         ILAMBD = WI(K)                                                 INV00590
         IF (K .EQ. 1) GO TO 280                                        INV00600
         KM1 = K - 1                                                    INV00610
         GO TO 240                                                      INV00620
C     ********** PERTURB EIGENVALUE IF IT IS CLOSE                      INV00630
C                TO ANY PREVIOUS EIGENVALUE **********                 +rNV00640
  220    RLAMBD = RLAMBD + EPS3                                         INV00650
C     ********** FOR I=K-1 STEP -1 UNTIL 1 DO -- **********             INV00660
  240    DO 260 II = 1, KM1                                             INV00670
            I = K - II                                                  INV00680
            IF (SELECT(I) .AND. DABS(WR(I)-RLAMBD) .LT. EPS3 .AND.      INV00690
     X         DABS(WI(I)-ILAMBD) .LT. EPS3) GO TO 220                  INV00700
  260    CONTINUE                                                       INV00710
C                                                                       INV00720
         WR(K) = RLAMBD                                                 INV00730
C     ********** PERTURB CONJUGATE EIGENVALUE TO MATCH **********       INV00740
         IP1 = K + IP                                                   INV00750
         WR(IP1) = RLAMBD                                               INV00760
C     ********** FORM UPPER HESSENBERG A-RLAMBD*I (TRANSPOSED)          rNV00770
C                AND INITIAL REAL VECTOR **********                     INV00780
  280    MP = 1                                                         INV00790
C                                                                       INV00800
         DO 320 I = 1, UK                                               INV00810
C                                                                       rNV00820
            DO 300 J = MP, UK                                           INV00830
  300       RM1(J,I) = A(I,J)                                           INV00840
C                                                                       INV00850
            RM1(I,I) = RM1(I,I) - RLAMBD                                INV00860
            MP = I                                                      INV00870
            RV1(I) = EPS3                                               rNV00880
  320    CONTINUE                                                       INV00890
C                                                                       INV00900
         ITS = 0                                                        INV00910
         IF (ILAMBD .NE. 0.0D0) GO TO 520                               INV00920
C     ********** REAL EIGENVALUE.                                       INV00930
C                TRIANGULAR DECOMPOSITION WITH INTERCHANGES,            INV00940
C                REPLACING ZERO PIVOTS BY EPS3 **********               INV00950
         IF (UK .EQ. 1) GO TO 420                                       INV00960
C                                                                       INV00970
         DO 400 I = 2, UK                                               INV00980
            MP = I - 1                                                  INV00990
            IF (DABS(RM1(MP,I)) .LE. DABS(RM1(MP,MP))) GO TO 360        INV01000
C                                                                       INV01010
            DO 340 J = MP, UK                                           INV01020
               Y = RM1(J,I)                                             INV01030
               RM1(J,I) = RM1(J,MP)                                     INV01040
               RM1(J,MP) = Y                                            INV01050
  340       CONTINUE                                                    INV01060
C                                                                       INV01070
  360       IF (RM1(MP,MP) .EQ. 0.0D0) RM1(MP,MP) = EPS3                INV01080
            X = RM1(MP,I) / RM1(MP,MP)                                  INV01090
            IF (X .EQ. 0.0D0) GO TO 400                                 INV01100
C                                                                       INV01110
            DO 380 J = I, UK                                            INV01120
  380       RM1(J,I) = RM1(J,I) - X * RM1(J,MP)                         INV01130
C                                                                       INV01140
  400    CONTINUE                                                       INV01150
C                                                                       INV01160
  420    IF (RM1(UK,UK) .EQ. 0.0D0) RM1(UK,UK) = EPS3                   INV01170
C     ********** BACK SUBSTITUTION FOR REAL VECTOR                      INV01180
C                FOR I=UK STEP -1 UNTIL 1 DO -- **********              rNV01190
  440    DO 500 II = 1, UK                                              INV01200
            I = UK + 1 - II                                             INV01210
            Y = RV1(I)                                                  INV01220
            IF (I .EQ. UK) GO TO 480                                    INV01230
            IP1 = I + 1                                                 INV01240
C                                                                       INV01250
            DO 460 J = IP1, UK                                          INV01260
  460       Y = Y - RM1(J,I) * RV1(J)                                   INV01270
C                                                                       INV01280
  480       RV1(I) = Y / RM1(I,I)                                       INV01290
  500    CONTINUE                                                       INV01300
C                                                                       INV01310
         GO TO 740                                                      INV01320
C     ********** COMPLEX EIGENVALUE.                                    INV01330
C                TRIANGULAR DECOMPOSITION WITH INTERCHANGES,            rNV01340
C                REPLACING ZERO PIVOTS BY EPS3.  STORE IMAGINARY        INV01350
C                PARTS IN UPPER TRIANGLE STARTING AT (1,3) **********   INV01360
  520    NS = N - S                                                     rNV01370
         Z(1,S-1) = -ILAMBD                                             INV01380
         Z(1,S) = 0.0D0                                                 INV01390
         IF (N .EQ. 2) GO TO 550                                        INV01400
         RM1(1,3) = -ILAMBD                                             INV01410
         Z(1,S-1) = 0.0D0                                               INV01420
         IF (N .EQ. 3) GO TO 550                                        INV01430
C                                                                       INV01440
         DO 540 I = 4, N                                                INV01450
  540    RM1(1,I) = 0.0D0                                               INV01460
C                                                                       INV01470
  550    DO 640 I = 2, UK                                               INV01480
            MP = I - 1                                                  INV01490
            W = RM1(MP,I)                                               INV01500
            IF (I .LT. N) T = RM1(MP,I+1)                               INV01510
            IF (I .EQ. N) T = Z(MP,S-1)                                 INV01520
            X = RM1(MP,MP) * RM1(MP,MP) + T * T                         INV01530
            IF (W * W .LE. X) GO TO 580                                 INV01540
            X = RM1(MP,MP) / W                                          INV01550
            Y = T / W                                                   INV01560
            RM1(MP,MP) = W                                              INV01570
            IF (I .LT. N) RM1(MP,I+1) = 0.0D0                           INV01580
            IF (I .EQ. N) Z(MP,S-1) = 0.0D0                             INV01590
C                                                                       INV01600
            DO 560 J = I, UK                                            INV01610
               W = RM1(J,I)                                             INV01620
               RM1(J,I) = RM1(J,MP) - X * W                             INV01630
               RM1(J,MP) = W                                            INV01640
               IF (J .LT. N1) GO TO 555                                 INV01650
               L = J - NS                                               INV01660
               Z(I,L) = Z(MP,L) - Y * W                                 INV01670
               Z(MP,L) = 0.0D0                                          INV01680
               GO TO 560                                                INV01690
  555          RM1(I,J+2) = RM1(MP,J+2) - Y * W                         INV01700
               RM1(MP,J+2) = 0.0D0                                      INV01710
  560       CONTINUE                                                    INV01720
C                                                                       INV01730
            RM1(I,I) = RM1(I,I) - Y * ILAMBD                            INV01740
            IF (I .LT. N1) GO TO 570                                    INV01750
            L = I - NS                                                  INV01760
            Z(MP,L) = -ILAMBD                                           INV01770
            Z(I,L) = Z(I,L) + X * ILAMBD                                INV01780
            GO TO 640                                                   INV01790
  570       RM1(MP,I+2) = -ILAMBD                                       rNV01800
            RM1(I,I+2) = RM1(I,I+2) + X * ILAMBD                        INV01810
            GO TO 640                                                   INV01820
  580       IF (X .NE. 0.0D0) GO TO 600                                 INV01830
            RM1(MP,MP) = EPS3                                           INV01840
            IF (I .LT. N) RM1(MP,I+1) = 0.0D0                           INV01850
            IF (I .EQ. N) Z(MP,S-1) = 0.0D0                             INV01860
            T = 0.0D0                                                   INV01870
            X = EPS3 * EPS3                                             INV01880
  600       W = W / X                                                   INV01890
            X = RM1(MP,MP) * W                                          INV01900
            Y = -T * W                                                  INV01910
C                                                                       INV01920
            DO 620 J = I, UK                                            INV01930
               IF (J .LT. N1) GO TO 610                                 INV01940
               L = J - NS                                               INV01950
               T = Z(MP,L)                                              INV01960
               Z(I,L) = -X * T - Y * RM1(J,MP)                          INV01970
               GO TO 615                                                INV01980
  610          T = RM1(MP,J+2)                                          INV01990
               RM1(I,J+2) = -X * T - Y * RM1(J,MP)                      INV02000
  615          RM1(J,I) = RM1(J,I) - X * RM1(J,MP) + Y * T              INV02010
  620       CONTINUE                                                    INV02020
C                                                                       INV02030
            IF (I .LT. N1) GO TO 630                                    INV02040
            L = I - NS                                                  INV02050
            Z(I,L) = Z(I,L) - ILAMBD                                    INV02060
            GO TO 640                                                   INV02070
  630       RM1(I,I+2) = RM1(I,I+2) - ILAMBD                            INV02080
  640    CONTINUE                                                       INV02090
C                                                                       INV02100
         IF (UK .LT. N1) GO TO 650                                      INV02110
         L = UK - NS                                                    INV02120
         T = Z(UK,L)                                                    INV02130
         GO TO 655                                                      INV02140
  650    T = RM1(UK,UK+2)                                               INV02150
  655    IF (RM1(UK,UK) .EQ. 0.0D0 .AND. T .EQ. 0.0D0) RM1(UK,UK) = EPS3INV02160
C     ********** BACK SUBSTITUTION FOR COMPLEX VECTOR                   INV02170
C                FOR I=UK STEP -1 UNTIL 1 DO -- **********              INV02180
  660    DO 720 II = 1, UK                                              INV02190
            I = UK + 1 - II                                             INV02200
            X = RV1(I)                                                  INV02210
            Y = 0.0D0                                                   rNV02220
            IF (I .EQ. UK) GO TO 700                                    INV02230
            IP1 = I + 1                                                 INV02240
C                                                                       INV02250
            DO 680 J = IP1, UK                                          INV02260
               IF (J .LT. N1) GO TO 670                                 INV02270
               L = J - NS                                               INV02280
               T = Z(I,L)                                               INV02290
               GO TO 675                                                INV02300
  670          T = RM1(I,J+2)                                           INV02310
  675          X = X - RM1(J,I) * RV1(J) + T * RV2(J)                   INV02320
               Y = Y - RM1(J,I) * RV2(J) - T * RV1(J)                   rNV02330
  680       CONTINUE                                                    INV02340
C                                                                       INV02350
  700       IF (I .LT. N1) GO TO 710                                    INV02360
            L = I - NS                                                  INV02370
            T = Z(I,L)                                                  INV02380
            GO TO 715                                                   INV02390
  710       T = RM1(I,I+2)                                              INV02400
  715       Z3 = DCMPLX(X,Y) / DCMPLX(RM1(I,I),T)                       INV02410
            RV1(I) = DREAL(Z3)                                          INV02420
            RV2(I) = DIMAG(Z3)                                          INV02430
  720    CONTINUE                                                       INV02440
C     ********** ACCEPTANCE TEST FOR REAL OR COMPLEX                    INV02450
C                EIGENVECTOR AND NORMALIZATION **********               INV02460
  740    ITS = ITS + 1                                                  INV02470
         NORM = 0.0D0                                                   INV02480
         NORMV = 0.0D0                                                  INV02490
C                                                                       INV02500
         DO 780 I = 1, UK                                               INV02510
            IF (ILAMBD .EQ. 0.0D0) X = DABS(RV1(I))                     INV02520
            IF (ILAMBD .NE. 0.0D0) X = CDABS(DCMPLX(RV1(I),RV2(I)))     INV02530
            IF (NORMV .GE. X) GO TO 760                                 INV02540
            NORMV = X                                                   INV02550
            J = I                                                       INV02560
  760       NORM = NORM + X                                             INV02570
  780    CONTINUE                                                       INV02580
C                                                                       INV02590
         IF (NORM .LT. GROWTO) GO TO 840                                INV02600
C     ********** ACCEPT VECTOR **********                               INV02610
         X = RV1(J)                                                     INV02620
         IF (ILAMBD .EQ. 0.0D0) X = 1.0D0 / X                           INV02630
         IF (ILAMBD .NE. 0.0D0) Y = RV2(J)                              rNV02640
C                                                                       INV02650
         DO 820 I = 1, UK                                               INV02660
            IF (ILAMBD .NE. 0.0D0) GO TO 800                            INV02670
            Z(I,S) = RV1(I) * X                                         INV02680
            GO TO 820                                                   INV02690
  800       Z3 = DCMPLX(RV1(I),RV2(I)) / DCMPLX(X,Y)                    INV02700
            Z(I,S-1) = DREAL(Z3)                                        rNV02710
            Z(I,S) = DIMAG(Z3)                                          INV02720
  820    CONTINUE                                                       INV02730
C                                                                       INV02740
         IF (UK .EQ. N) GO TO 940                                       INV02750
         J = UK + 1                                                     INV02760
         GO TO 900                                                      INV02770
C     ********** IN-LINE PROCEDURE FOR CHOOSING                         INV02780
C                A NEW STARTING VECTOR **********                       INV02790
  840    IF (ITS .GE. UK) GO TO 880                                     INV02800
         X = UKROOT                                                     INV02810
         Y = EPS3 / (X + 1.0D0)                                         rNV02820
         RV1(1) = EPS3                                                  INV02830
C                                                                       INV02840
         DO 860 I = 2, UK                                               INV02850
  860    RV1(I) = Y                                                     INV02860
C                                                                       INV02870
         J = UK - ITS + 1                                               INV02880
         RV1(J) = RV1(J) - EPS3 * X                                     INV02890
         IF (ILAMBD .EQ. 0.0D0) GO TO 440                               INV02900
         GO TO 660                                                      INV02910
C     ********** SET ERROR -- UNACCEPTED EIGENVECTOR **********         INV02920
  880    J = 1                                                          INV02930
         IERR = -K                                                      INV02940
C     ********** SET REMAINING VECTOR COMPONENTS TO ZERO **********     INV02950
  900    DO 920 I = J, N                                                INV02960
            Z(I,S) = 0.0D0                                              INV02970
            IF (ILAMBD .NE. 0.0D0) Z(I,S-1) = 0.0D0                     INV02980
  920    CONTINUE                                                       INV02990
C                                                                       INV03000
  940    S = S + 1                                                      INV03010
  960    IF (IP .EQ. (-1)) IP = 0                                       INV03020
         IF (IP .EQ. 1) IP = -1                                         INV03030
  980 CONTINUE                                                          INV03040
C                                                                       INV03050
      GO TO 1001                                                        INV03060
C     ********** SET ERROR -- UNDERESTIMATE OF EIGENVECTOR              INV03070
C                SPACE REQUIRED **********                              INV03080
 1000 IF (IERR .NE. 0) IERR = IERR - N                                  INV03090
      IF (IERR .EQ. 0) IERR = -(2 * N + 1)                              INV03100
 1001 M = S - 1 - IABS(IP)                                              INV03110
      RETURN                                                            INV03120
C     ********** LAST CARD OF INVIT **********                          INV03130
      END                                                               INV03140
      SUBROUTINE RDTITL                                                 RDT00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         RDT00020
      COMMON/LINES/TITLE(10),TIL(3),NLP,LIN                             RDT00030
      COMMON/FORM/FMT1(2),FMT2(2),NEPR                                  RDT00040
      COMMON/TOL/EPSAM,EPSBM,IACM                                       RDT00050
      COMMON/CONV/SUMCV,RICTCV,SERCV,MAXSUM                             RDT00060
C     NLP = NO. LINES/PAGE VARIES WITH THE INSTALLATION                 RDT00070
      READ(5,100,END=90,ERR=91) TITLE                                   RDT00080
  100 FORMAT(10A8)                                                      RDT00090
      CALL LNCNT(100)                                                   RDT00100
      RETURN                                                            RDT00110
   90 CONTINUE                                                          RDT00120
      STOP 1                                                            RDT00130
   91 CONTINUE                                                          RDT00140
      STOP 2                                                            RDT00150
      END                                                               RDT00160
      BLOCK DATA                                                        MOD00670
      IMPLICIT REAL*8 (A-H,O-Z)                                         MOD00680
      COMMON/LINES/TITLE(10),TIL(3),NLP,LIN                             MOD00690
      COMMON/FORM/FMT1(2),FMT2(2),NEPR                                  MOD00700
      COMMON/TOL/EPSAM,EPSBM,IACM                                       MOD00710
      COMMON/CONV/SUMCV,RICTCV,SERCV,MAXSUM                             MOD00720
      DATA LIN,NLP/1,58/                                                MOD00730
      DATA NEPR,FMT1/7,8H(1P7D16.,8H7)      /                           MOD00740
      DATA TIL/8H     ORA,8HCLS  PRO,8HGRAM    /                        MOD00750
      DATA FMT2/8H(3X,1P7D,8H16.7)   /                                  MOD00760
      DATA EPSAM/1.E-10/                                                MOD00770
      DATA EPSBM/1.E-10/                                                MOD00780
      DATA IACM/12/                                                     MOD00790
      DATA SUMCV/1.E-8/                                                 MOD00800
      DATA RICTCV/1.E-8/                                                MOD00810
      DATA SERCV/1.E-8/                                                 MOD00820
      DATA MAXSUM/50/                                                   MOD00830
      END                                                               MOD00840
      SUBROUTINE GELIM(NMAX,N,A,NRHS,B,IPIVOT,IFAC,WK,IERR)             GEL00010
      IMPLICIT REAL*8 (A-H,O-Z)                                         GEL00020
      DIMENSION A(NMAX,1),B(NMAX,1),IPIVOT(1),WK(1)                     GEL00030
      IERR=0                                                            GEL00040
C                                                                       GEL00050
C     TEST FOR L/U FACTORIZATION                                        GEL00060
C                                                                       GEL00070
      IF(IFAC.EQ.1)GO TO 10                                             GEL00080
      CALL DETFAC(NMAX,N,A,IPIVOT,IFAC,DETERM,ISCALE,WK,IERR)           GEL00090
      IF(IERR.GT.0)RETURN                                               GEL00100
      IF (IFAC.EQ.2) DETA=DETERM*(10.**(100*ISCALE))
   10 NM1=N-1                                                           GEL00110
C                                                                       GEL00120
C     TEST FOR SCALAR A MATRIX                                          GEL00130
C                                                                       GEL00140
      IF(NM1.GT.0)GO TO 40                                              GEL00150
      IF(A(1,1).EQ.0.)GO TO 30                                          GEL00160
      DO 20 I=1,NRHS                                                    GEL00170
   20 B(1,I)=B(1,I)/A(1,1)                                              GEL00180
      IF (IFAC.EQ.2) WK(1)=DETA
      RETURN                                                            GEL00190
   30 IERR=1                                                            GEL00200
      RETURN                                                            GEL00210
C                                                                       GEL00220
   40 DO 100 M=1,NRHS                                                   GEL00230
C                                                                       GEL00240
C     PIVOT THE M-TH COLUMN OF B MATRIX                                 GEL00250
C                                                                       GEL00260
      DO 50 I=1,NM1                                                     GEL00270
      KI=IPIVOT(I)                                                      GEL00280
      P=B(KI,M)                                                         GEL00290
      B(KI,M)=B(I,M)                                                    GEL00300
   50 B(I,M)=P                                                          GEL00310
C                                                                       GEL00320
C     FORWARD SUBSTITUTION                                              GEL00330
C                                                                       GEL00340
      WK(1)=B(1,M)                                                      GEL00350
C                                                                       GEL00360
      DO 70 I=2,N                                                       GEL00370
      IM1=I-1                                                           GEL00380
      P=0.0                                                             GEL00390
      DO 60 K=1,IM1                                                     GEL00400
   60 P=P+A(I,K)*WK(K)                                                  GEL00410
   70 WK(I)=B(I,M)-P                                                    GEL00420
C                                                                       GEL00430
C     BACK SUBSTITUTION                                                 GEL00440
C                                                                       GEL00450
      B(N,M)=WK(N)/A(N,N)                                               GEL00460
C                                                                       GEL00470
      DO 90 J=1,NM1                                                     GEL00480
      I=N-J                                                             GEL00490
      IP1=I+1                                                           GEL00500
      P=WK(I)                                                           GEL00510
      DO 80 K=IP1,N                                                     GEL00520
   80 P=P-A(I,K)*B(K,M)                                                 GEL00530
   90 B(I,M)=P/A(I,I)                                                   GEL00540
C                                                                       GEL00550
  100 CONTINUE                                                          GEL00560
      IF (IFAC.EQ.2) WK(1)=DETA
      RETURN                                                            GEL00570
      END                                                               GEL00580
      SUBROUTINE PNCH (A,NA,NAM,IOP)
C IOP(1)=0, SKIP TITLE; IOP(2)=N, SKIP LINES; IOP(3)=1, TAB 25 SPACES.
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),IOP(4),NA(2)
      NR=NA(1)
      NC=NA(2)
      NMAX=NR*NC
      NSKIP=IOP(2)
      IF (IOP(2).EQ.0) GO TO 205
      DO 200 I=1,NSKIP
  200 WRITE(7,150)
  150 FORMAT(2X)
  205 CONTINUE
      IF (IOP(1).EQ.0) GO TO 210
      WRITE(7,151) NAM,NR,NC
  151 FORMAT(A4,/,2I5)
  210 CONTINUE
      DO 250 I=1,NR
      IF (IOP(3).EQ.0) WRITE(7,152) (A(J),J=I,NMAX,NR)
      IF (IOP(3).NE.0) WRITE(7,153) (A(J),J=I,NMAX,NR)
  250 CONTINUE
  152 FORMAT(6(1PD13.5))
  153 FORMAT(25X,6(1PD13.5))
      RETURN
      END
